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