aus Metalab Wiki, dem offenen Zentrum für meta-disziplinäre Magier und technisch-kreative Enthusiasten.
;;;
;;; 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))