(defpackage "CIRCUITS" (:use "COMMON-LISP" "EXTENSIONS") (:export "CONNECT" "OUTPUT-STATES" "OUTPUT-STATE" "SIMULATE" "SWITCH" "MAKE-SWITCH" "SWITCH-TOGGLE" "SWITCH-POSITION" "ZERO" "MAKE-ZERO" "COMPLEX-CIRCUIT" "MAKE-COMPLEX-CIRCUIT" "NEW-CERTIFIED-COMPLEX" "DEF-OUTPUT" "BRANCH-INPUT" "SHORT-CIRCUIT" "MAKE-FLIP-FLOP" "PARALLEL" "SERIE" "COMP-DESCRIBE")) (in-package circuits) ;;;; components with some inputs and outputs (defclass component () ((inputs :reader component-inputs) (outputs :reader component-outputs) (nb-in :reader component-nb-in :initarg :nb-in) (nb-out :reader component-nb-out :initarg :nb-out)) (:documentation "a network component")) (defmethod initialize-instance :after ((c component) &key) (setf (slot-value c 'inputs) (make-array (slot-value c 'nb-in))) (setf (slot-value c 'outputs) (make-array (slot-value c 'nb-out)))) (defgeneric comp-describe ((c component) &key (stream t))) ;;;; checks if all the inputs of a component are connected (defun connected (position) (functionp position)) (defun all-connected (plots) (every #'connected plots)) (defun connect (&key from (n-output 0) to n-input) "(connect :from from :n-output i :to to :n-input j) connects the i-th output of component from to the j-th input of component to" (assert (and (<= 0 n-output) (<= 0 n-input) (< n-input (component-nb-in to)) (< n-output (component-nb-out from)))) (setf (svref (component-inputs to) n-input) #'(lambda () (output-state from n-output))) t) (defun output-states (c) "(output-states c) returns the vector of state outputs of c" (map 'vector #'funcall (component-outputs c))) (defun output-state (c position ) "(output-state c i) returns the i-th state output of c" (funcall (svref (component-outputs c) position))) ;;;; simulation ;;; realizes the first half of a clock tic (defmethod compute-temp-state ((c component)) ;; do nothing nil ) ;;; realizes the second half of a clock tic , returns t if the ;;; component is stable (defmethod update ((c component)) ;; stable by default t ) (defun simulate (c time) "(simulate )" (assert (all-connected (component-inputs c))) (format t "~s~%" (output-states c)) (dotimes (i time nil) (compute-temp-state c) (when (update c) (format t "STABLE !~%") (return t)) (format t "~s~%" (output-states c)))) (defmethod comp-describe ((c component) &key (stream t) ) (format stream "a plain component with ~d inputs and ~d outputs~%" (component-nb-in c) (component-nb-out c)) (format stream "bound inputs : ~s~%" (map 'vector #'functionp (component-inputs c))) (format stream "bound outputs : ~s~%" (map 'vector #'functionp (component-outputs c)))) ;;;; zeros (defclass zero (component) ((nb-in :initform 0) (nb-out :initform 1))) (defmethod initialize-instance :after ((z zero) &key) (setf (svref (component-outputs z) 0) #'(lambda () nil))) (defun make-zero () (make-instance 'zero)) ;;;; switches (defclass switch (component) ((nb-in :initform 0 :allocation :class) (nb-out :initform 1 :allocation :class) (switch-position :initform nil :accessor switch-position))) (defmethod initialize-instance :after ((sw switch) &key) (setf (svref (component-outputs sw) 0) #'(lambda () (switch-position sw)))) (defun make-switch () (make-instance 'switch)) (defun switch-toggle (sw) (setf (switch-position sw) (not (switch-position sw )))) (defmethod comp-describe ((sw switch) &key (stream t)) (format stream "a switch at position ~s~%" (switch-position sw))) ;;;; portes (defclass gate (component) ((nb-out :initform 1 :allocation :class) (nb-in :initform 2 ; valeur par defaut :allocation :class) (fun :reader gate-fun :allocation :class) (temp-state) (current-state :reader current-state :initform nil)) (:documentation "a component n to 1 together with a function applied to its inputs")) (defmethod initialize-instance :after ((g gate) &key) (setf (svref (slot-value g 'outputs) 0) #'(lambda () (current-state g)))) (defmethod comp-describe ((g gate) &key (stream t)) (format stream "a gate with ~d entries and output at : ~d ~%" (component-nb-in g) (output-state g 0))) (defmethod compute-temp-state ((g gate)) (setf (slot-value g 'temp-state ) (apply (gate-fun g) (map 'list #'funcall (component-inputs g))))) (defmethod update ((g gate)) (let ((old (slot-value g 'current-state))) (setf (slot-value g 'current-state) (slot-value g 'temp-state)) (eql old (slot-value g 'temp-state)))) ; local stability (defun gate-class (name) (intern (concatenate 'string (string-upcase name) "-GATE"))) (defun build-gate (name) (intern (concatenate 'string "MAKE-" (string-upcase name) "-GATE"))) ;;;; usages (defgate name function) ;;;; (defgate name function :arity n) ;;;; (defgate name function :arity :variable) (defmacro defgate (name fun &key arity) (let ((class-name (gate-class name)) (maker (build-gate name))) `(progn (defclass ,class-name (gate) ((fun :initform (function ,fun) :allocation :class) ,@(when (numberp arity) `((nb-in :initform ,arity :allocation :class))) ,@(when (eq arity :variable) `((nb-in :initarg :arity :allocation :instance))))) ,(if (eq arity :variable) `(defun ,maker (arity) (make-instance ',class-name :arity arity)) `(defun ,maker () (make-instance ',class-name))) (export (list ',class-name ',maker)) ',class-name))) ;;;; specialized gates (defgate and (lambda (x y) (and x y))) (defgate or (lambda (x y) (or x y))) (defgate xor (lambda (x y) (not (eql x y)))) (defgate nor (lambda (x y) (not (or x y)))) (defgate nand (lambda (x y) (not (and x y)))) (defgate not not :arity 1) ;;;; gates with unspecified arity (defgate and* (lambda (&rest l) (every #'identity l)) :arity :variable) (defgate or* (lambda (&rest l) (some #'identity l)) :arity :variable) ;;;; Circuits complexes (defclass complex-circuit (component) ((subcomponents :reader complex-circuit-subs :initarg :subs)) (:documentation "circuits with various inputs, outputs, and substructures")) ;;; checks wether all connexions are defined ;;; doesn't check wether the entries are connected ;;; this job is done either by building a larger component ;;; or by simulate (defun check-complex (comp) (and (all-connected (component-outputs comp)) (not (find-if-not #'(lambda (sub) (all-connected (component-inputs sub))) (complex-circuit-subs comp))))) (defun make-complex-circuit (subs nb-in nb-out) (make-instance 'complex-circuit :subs subs :nb-in nb-in :nb-out nb-out)) ;;; builds a checked complex circuit ;;; ;;; Notice that the connections must be INSIDE the ;;; (new-certified-complex ...) block (defmacro new-certified-complex (name subs nb-in nb-out &body connections ) `(let ((,name (make-instance 'complex-circuit :subs ,subs :nb-in ,nb-in :nb-out ,nb-out))) (progn ,@connections) (assert (check-complex ,name)) ,name)) (defun def-output (&key of (o1 0 ) as (o2 0)) "(def-output of o1 as o2 ) defines the o1-th output of 'of' as the o2-th output of 'as'" (assert (and (<= 0 o1) (<= 0 o2) (typep of 'complex-circuit) (typep as 'component) (< o1 (component-nb-out of)) (< o2 (component-nb-out as)))) (setf (svref (component-outputs of) o1) #'(lambda () (output-state as o2 )))) (defun branch-input (&key c1 (i1 0) c2 (i2 0)) "(branch-input c1 i1 c2 i2) branches the i1-th input of c1 to the i2-th input of its subcomponent c2" (assert (and (<= 0 i1) (<= 0 i2) (typep c1 'complex-circuit) (typep c2 'component) (< i1 (component-nb-in c1)) (< i2 (component-nb-in c2)))) (setf (svref (component-inputs c2) i2) #'(lambda () (funcall (svref (component-inputs c1) i1))))) (defun short-circuit (&key c i1 o1) "(short-circuit c i1 o1) branches directly the i1-th input of c to it's o1-th output" (assert (and (<= 0 i) (<= 0 j) (typep c 'complex-circuit) (< i (component-nb-in cc)) (< j (component-nb-out sc)))) (setf (svref (component-outputs cc) j) #'(lambda () (funcall (svref (component-inputs cc) i))))) (defmethod compute-temp-state ((c complex-circuit)) (mapc #'compute-temp-state (complex-circuit-subs c))) (defmethod update ((c complex-circuit)) (every #'identity (mapcar #'update (complex-circuit-subs c)))) ;;;; flip-flop (defun make-flip-flop () (let* ((g1 (make-nor-gate)) (g2 (make-nor-gate))) (new-certified-complex f (list g1 g2) 2 2 (branch-input :c1 f :i1 0 :c2 g1 :i2 0) (branch-input :c1 f :i1 1 :c2 g2 :i2 1) (connect :from g1 :to g2 :n-input 0) (connect :from g2 :to g1 :n-input 1) (def-output :of f :as g1 ) (def-output :of f :o1 1 :as g2 )))) ;;;; general operators for composition (defmethod parallel ((comp1 component) (comp2 component)) (let ((n1 (component-nb-in comp1)) (n2 (component-nb-in comp2)) (p1 (component-nb-out comp1)) (p2 (component-nb-out comp2))) (new-certified-complex comp (list comp1 comp2) (+ n1 n2) (+ p1 p2) (dotimes (i n1 t) (branch-input :c1 comp :i1 i :c2 comp1 :i2 i)) (dotimes (i n2 t) (branch-input :c1 comp :i1 (+ i n1) :c2 comp2 :i2 i)) (dotimes (i p1 t) (def-output :of comp :o1 i :as comp1 :o2 i)) (dotimes (i p2 t) (def-output :of comp :o1 (+ i p1) :as comp2 :o2 i))))) (defmethod serie ((comp1 component) (comp2 component)) (let ((n1 (component-nb-in comp1)) (n2 (component-nb-in comp2)) (p1 (component-nb-out comp1)) (p2 (component-nb-out comp2))) (assert (= p1 n2)) (new-certified-complex comp (list comp1 comp2) n1 p2 (dotimes (i n1 t) (branch-input :c1 comp :i1 i :c2 comp1 :i2 i)) (dotimes (i p2 t) (def-output :of comp :o1 i :as comp2 :o2 i)) (dotimes (i p1 t) (connect :from comp1 :n-output i :to comp2 :n-input i))))) (defmethod buggy-parallel ((comp1 component) (comp2 component)) (let ((n1 (component-nb-in comp1)) (n2 (component-nb-in comp2)) (p1 (component-nb-out comp1)) (p2 (component-nb-out comp2))) (new-certified-complex comp (list comp1 comp2) (+ n1 n2) (+ p1 p2) (dotimes (i (- n1 1) t) ; here ! (branch-input :c1 comp :i1 i :c2 comp1 :i2 i)) (dotimes (i n2 t) (branch-input :c1 comp :i1 (+ i n1) :c2 comp2 :i2 i)) (dotimes (i p1 t) (def-output :of comp :o1 i :as comp1 :o2 i)) (dotimes (i p2 t) (def-output :of comp :o1 (+ i p1) :as comp2 :o2 i)))))