Logi-1.lisp

;;; component for https://metalab.at/wiki/Was_wei%C3%9F_das_metalab_%C3%BCber_digitaltechnik%3F

;;;
;;; made for SBCL Common Lisp 
;;; only non-portable is #'sb-introspect:function-lambda-list
;;; for determining what arguments a given function has
;;; here, we are only interested of the length of the lambda 
;;; list and take that as face-value, without looking at
;;; &optional, keywords and the like
;;; 

;;; load that non-portable function
(require 'sb-introspect)

;;; this program can simulate logical functions (with no state
;;; or feedback)
;;; implemented are AND, OR, NOT, XNOR, etc, as well as
;;; other textbook examples. 

;;; basic logic
;;; this is just playfulness. roll your own if you don't like it
;;; the following program does not contain lisp integer 
;;; arithmetic. for cubistic reasons, we implement addition
;;; in logic ops

(defun h-or-2 (p q) (if p t q))
(defun h-and-2 (p q) (when p q))
(defun h-not (p) (null p))

;;; not the shortest route, but more scenic

(defun invertor (h-fun) 
  #'(lambda (&rest fun-args)
    (h-not (apply h-fun fun-args))))

(setf (symbol-function 'h-nor-2) (invertor #'h-or-2))
(setf (symbol-function 'h-nand-2) (invertor #'h-and-2))

(defun sameor (h-fun)
  #'(lambda (p q)
    (let*
      ((le-1 (apply h-fun (list p q))))
        (apply h-fun 
          (list
            (apply h-fun (list le-1 p))
            (apply h-fun (list le-1 q)))))))

(setf (symbol-function 'h-xor-2) (sameor #'h-nand-2))
(setf (symbol-function 'h-xnor-2) (sameor #'h-nor-2))

;;; at this point, we have a full set of common
;;; logic functions, from or over nand to xnor, etc. 

;;; this is the full adder from an illustration of the
;;; logic circuit in wikipedia, "full adder", for a single
;;; binary digit. The function returns two results: 
;;; 1.) the 2^0 digit (default) 2.) the 2^1 digit 

;;; making a dedicated logic function is like sharing
;;; an output in a circuit. 

(defun h-full-adder-xor-shared (x y)
  (h-xor-2 x y))

;;; this for computing the 2^0 part
(defun h-full-adder-1er (x y c)
  (h-xor-2 (h-full-adder-xor-shared x y) c))

;;; this is for computing the 2^1 part
(defun h-full-adder-2er (x y c)
  (h-or-2 
    (h-and-2 
       c 
       (h-full-adder-xor-shared x y))
    (h-and-2 x y)))

;;; returns results for 1er and 2er -- duh...  
(defun h-full-adder (x y c)
  (values 
    (h-full-adder-1er x y c) 
    (h-full-adder-2er x y c)))

;;; here we start building a binary from h-full-adder,
;;; for an arbitrary number of digits. the function does
;;; not contain any loops; we use recursion instead. 
;;; the recusion ends when both the list for x arg and 
;;; the list for y arg are finally empty. 
;;; since the most significant bit is processed last,
;;; the resulting trues and falses in the result list
;;; is in order. However, note that the x-arg list (xs)
;;; and the y-arg list (ys) must be reversed for that
;;; purpose. This is done in the wrapper below. You can
;;; use this function for padding logically represented
;;; integers to a certain numbers of digits. Each recursion
;;; would be another copy of a full-adder circuit. 

(defun h-add-2c-core (xs ys c accu)
  (let*
    ((x (car xs))
     (y (car ys)))
    (if (h-nor-2 (consp xs) (consp ys))
      (if c (cons c accu) accu)

      (multiple-value-bind (r nc) (h-full-adder x y c)
        (h-add-2c-core (cdr xs) (cdr ys) nc (cons r accu))))))

;;; wrapper. note that we turn a nil into (nil) to constitute
;;; a 0 (if... in the last line

(defun h-add-2c (xs ys c)
  (let*
    ((r (h-add-2c-core (reverse xs) (reverse ys) c nil)))
      (if r r (cons r nil))))

;;; another recursive function, for building a list of
;;; numbers in ascending order. You start at '(t nil nil),
;;; for example and end at '(t t t), when the number space
;;; is exhausted. '(nil nil nil nil nil) runs to 
;;; '(t t t t t) for another example. 

(defun h-count-up-build-core (begin accu)
  (if (every #'identity begin)
    (cons begin accu)
    (h-count-up-build-core 
      (h-add-2c begin nil t) 
      (cons begin accu))))

;;; actual function for wrapping

(defun h-count-up-build (begin)
  (reverse (h-count-up-build-core begin nil)))

;;; this function is for avoiding the length of the list
;;; as lisp integer. instead, we take the list passed
;;; in modelst as a model and scoure it to the end recursively,
;;; adding a given thing named what to the result as each
;;; step. Thus (mimick-len-what '(hugo otto batman) 'ninetynine))
;;; gives you '(ninetynine, ninetynine, ninetynine). 

(defun mimick-len-what (modelst what &optional accu)
  (if (null modelst)
    accu
    (mimick-len-what (cdr modelst) what (cons what accu))))

;;; here we generate a truth-table in two steps. 
;;; in the first step we generate the list of possible
;;; inputs with h-count-up-build. How many inputs, you
;;; ask? We start with the list of inputs, as retrieved with
;;; that nonportable function. It determines the list of 
;;; inputs for a (logical) function, let's say a full-adder,
;;; i.e. '(x y c). With mimick-len-what we make that
;;; (nil nil nil) and pass it to h-count-up-build.
;;; in the second step we scour that list of inputs
;;; and apply those inputs to the given function.
;;; the result is the desired truth-table. 

(defun h-truth-table-from-h-fun (h-fun)
  (mapcar
    #'(lambda (args)
      (apply h-fun args))
    (h-count-up-build 
      (mimick-len-what 
        (sb-introspect:function-lambda-list h-fun) ;;; SBCL only
        nil))))

;;; 
;;; multor takes a 2-value log function and
;;; gives you an n-value log function
;;; does not make sense for all 2-value log functions,
;;; but makes total sense for at least and and or. 
;;; 

(defun multor (h-2-fun initor)
  #'(lambda (&rest args)
    (reduce h-2-fun args :initial-value initor)))

(setf (symbol-function 'h-and-n) (multor #'h-and-2 t))
(setf (symbol-function 'h-or-n) (multor #'h-or-2 nil))