From 5f1847c0f0daa554df0dbaeee68fce64bef298ed Mon Sep 17 00:00:00 2001 From: Anthony Hart Date: Tue, 25 Apr 2023 00:55:06 -0700 Subject: [PATCH] Added Bitc polynomial backend and transformation to vampir Adds category of boolean circuits (BITC). The objects in this category are just natural numbers representing the type of bit vectors of a certain length. There are nine methods for constructing morphisms; - (compose x y), which composes morphisms x and y. - (ident n), which is the identity on n. - (fork n), which maps n onto 2*n by copying its inputs. - (parallel x y), which (if x : a -> b and y : c -> d) will be a morphism from a + c -> b + d, running x and y on subvectors. - (swap n m), which maps n + m onto m + n by swapping. - ONE, which represents the map from 0 onto 1 producing a vector with only 1 in it. - ZERO, which represents the map from 0 onto 1 producing a vector with only 0 in it. - (drop n), which represents the unique morphism from n to 0. - (branch x y), which (if x : a -> b and y : a -> b) maps 1+a to b by splitting on the first bit to decide which morphism to apply to the remaining bits. There are other ways to formulate this category, but I think this particular formulation is quite convenient. I've implemented a `to-bitc` function in geb.trans which translates geb objects and morphisms into bitc objects and morphisms. Additionally, I've implemented a `to-vampir` function in bitc.trans which translates a bit morphism into a vampire morphism. I'm not sure what else is needed, but the core implementation is done for now. In the future, this should be extended to a category whose objects represent vectors over some finite set other than the booleans. The reason I didn't do that hear is because coproducts are only binary and there aren't finite sets beyond so0 and so1, so bitvectors are quite natural and using anything else would require post-hoc optimization, but future versions of geb may want more. Also, I'd like to know what, if any, performance benefits this gives over the univariate polynomial formulation. I didn't test that. --- docs/documentation.lisp | 1 + docs/package.lisp | 1 + geb.asd | 18 +++++- src/bitc/bitc.lisp | 33 ++++++++++ src/bitc/package.lisp | 54 ++++++++++++++++ src/bitc/trans.lisp | 89 +++++++++++++++++++++++++++ src/entry/package.lisp | 1 + src/geb/package.lisp | 7 ++- src/geb/trans.lisp | 110 +++++++++++++++++++++++++++++++++ src/specs/bitc-printer.lisp | 26 ++++++++ src/specs/bitc.lisp | 119 ++++++++++++++++++++++++++++++++++++ src/specs/package.lisp | 39 ++++++++++++ src/specs/poly-printer.lisp | 6 +- test/bitc.lisp | 21 +++++++ test/geb.lisp | 2 + test/package.lisp | 1 + 16 files changed, 520 insertions(+), 8 deletions(-) create mode 100644 src/bitc/bitc.lisp create mode 100644 src/bitc/package.lisp create mode 100644 src/bitc/trans.lisp create mode 100644 src/specs/bitc-printer.lisp create mode 100644 src/specs/bitc.lisp create mode 100644 test/bitc.lisp diff --git a/docs/documentation.lisp b/docs/documentation.lisp index 22f157d1b..841c65808 100644 --- a/docs/documentation.lisp +++ b/docs/documentation.lisp @@ -12,6 +12,7 @@ (@idioms pax:section) (@geb pax:section) (@geb-gui-manual pax:section) + (@bitc-manual pax:section) (@poly-manual pax:section) (@stlc pax:section) (@mixins pax:section) diff --git a/docs/package.lisp b/docs/package.lisp index b2d75921b..c78e43f33 100644 --- a/docs/package.lisp +++ b/docs/package.lisp @@ -5,6 +5,7 @@ (:import-from #:geb.utils #:@geb-utils-manual) (:import-from #:geb-test #:@geb-test-manual) (:import-from #:geb.poly #:@poly-manual) + (:import-from #:geb.bitc #:@bitc-manual) (:import-from #:geb.specs #:@geb-specs) (:import-from #:geb.entry #:@geb-entry) (:import-from #:geb.lambda #:@stlc) diff --git a/geb.asd b/geb.asd index fd0baef65..d1495eb04 100644 --- a/geb.asd +++ b/geb.asd @@ -9,11 +9,15 @@ :description "Gödel, Escher, Bach, a categorical view of computation" :build-pathname "../build/geb.image" :entry-point "geb.entry::entry" + :build-operation "program-op" :author "Mariari" + :license "MIT" + :pathname "src/" :components + ((:module util :serial t :description "Internal utility functions" @@ -46,6 +50,12 @@ :description "Polynomial" :depends-on (util geb vampir specs) :components ((:file package))) + (:module bitc + :serial t + :description "bitc (Boolean Circuits)" + :depends-on (util vampir mixins specs) + :components ((:file package) + (:file bitc))) (:module lambda :serial t :depends-on (geb specs) @@ -68,6 +78,8 @@ (:file lambda) (:file poly) (:file poly-printer) + (:file bitc) + (:file bitc-printer) ;; HACK: to make the package properly refer to the ;; right symbols (:file ../util/package))) @@ -81,11 +93,12 @@ :pathname "../src/" :components ((:file lambda/trans) (:file geb/trans) - (:file poly/trans))) + (:file poly/trans) + (:file bitc/trans))) (:module entry :serial t :description "Entry point for the geb codebase" - :depends-on (util geb vampir specs poly lambda) + :depends-on (util geb vampir specs poly bitc lambda) :components ((:file package) (:file entry)))) :in-order-to ((asdf:test-op (asdf:test-op :geb/test)))) @@ -124,6 +137,7 @@ (:file lambda) (:file lambda-conversion) (:file poly) + (:file bitc) (:file pipeline) (:module gui :serial t diff --git a/src/bitc/bitc.lisp b/src/bitc/bitc.lisp new file mode 100644 index 000000000..141fc33c8 --- /dev/null +++ b/src/bitc/bitc.lisp @@ -0,0 +1,33 @@ +(in-package :geb.bitc.main) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Domain and codomain definitions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod dom ((x )) + (typecase-of bitc x + (compose (dom (mcadr x))) + (fork (dom (mcar x))) + (parallel (+ (dom (mcar x)) (dom (mcadr x)))) + (swap (+ (mcar x) (mcadr x))) + (one 0) + (zero 0) + (ident (mcar x)) + (drop (mcar x)) + (branch (+ 1 (dom (mcar x)))) + (otherwise + (subclass-responsibility x)))) + +(defmethod codom ((x )) + (typecase-of bitc x + (compose (codom (mcar x))) + (fork (* 2 (codom (mcar x)))) + (parallel (+ (codom (mcar x)) (codom (mcadr x)))) + (swap (+ (mcar x) (mcadr x))) + (one 1) + (zero 1) + (ident (mcar x)) + (drop 0) + (branch (codom (mcar x))) + (otherwise + (subclass-responsibility x)))) diff --git a/src/bitc/package.lisp b/src/bitc/package.lisp new file mode 100644 index 000000000..c747e4045 --- /dev/null +++ b/src/bitc/package.lisp @@ -0,0 +1,54 @@ +(in-package :geb.utils) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; trans module +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(muffle-package-variance + (defpackage #:geb.bitc.trans + (:local-nicknames (:vamp :geb.vampir.spec)) + (:use #:geb.common #:geb.bitc.spec) + (:shadowing-import-from #:geb.bitc.spec #:drop #:fork))) + +(in-package :geb.bitc.trans) + +(pax:defsection @bitc-trans (:title "Bits (Boolean Circuit) Transformations") + "This covers transformation functions from" + (to-circuit pax:function) + (to-vampir pax:generic-function) + (to-vampir (pax:method () (compose t))) + (to-vampir (pax:method () (fork t))) + (to-vampir (pax:method () (parallel t))) + (to-vampir (pax:method () (swap t))) + (to-vampir (pax:method () (one t))) + (to-vampir (pax:method () (zero t))) + (to-vampir (pax:method () (ident t))) + (to-vampir (pax:method () (drop t))) + (to-vampir (pax:method () (branch t)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; bitc module +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(geb.utils:muffle-package-variance + (uiop:define-package #:geb.bitc.main + (:use #:geb.common #:geb.mixins) + (:shadowing-import-from #:geb.bitc.spec #:drop #:fork) + (:use-reexport #:geb.bitc.trans #:geb.bitc.spec))) + +(geb.utils:muffle-package-variance + (uiop:define-package #:geb.bitc + (:use #:geb.common) + (:shadowing-import-from #:geb.bitc.spec :fork :drop) + (:use-reexport #:geb.bitc.trans #:geb.bitc.spec #:geb.bitc.main))) + +(in-package :geb.bitc.main) + +(in-package :geb.bitc) + +(pax:defsection @bitc-manual (:title "Bits (Boolean Circuit) Specification") + "This covers a GEB view of Boolean Circuits. In particular this type will +be used in translating GEB's view of Boolean Circuits into Vampir" + (@bitc pax:section) + (@bitc-constructors pax:section) + (@bitc-trans pax:section)) diff --git a/src/bitc/trans.lisp b/src/bitc/trans.lisp new file mode 100644 index 000000000..e8e20800d --- /dev/null +++ b/src/bitc/trans.lisp @@ -0,0 +1,89 @@ +(in-package :geb.bitc.trans) + +(defgeneric to-vampir (morphism values) + (:documentation "Turns a BITC term into a Vamp-IR term with a given value")) + +(defun to-circuit (morphism name) + "Turns a BITC term into a Vamp-IR Gate with the given name" + (let* ((wire-count (dom morphism)) + (wires (loop for i from 1 to wire-count + collect (vamp:make-wire :var (intern (format nil "x~a" i) + :keyword))))) + (vamp:make-alias :name name + :inputs wires + :body (to-vampir morphism wires)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Bits to Vampir Implementation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod to-vampir ((obj ) values) + (declare (ignore values)) + (subclass-responsibility obj)) + +(defun infix-creation (symbol value1 value2) + (vamp:make-infix :op symbol + :lhs value1 + :rhs value2)) + +(defmethod to-vampir ((obj compose) values) + (to-vampir (mcar obj) + (to-vampir (mcadr obj) values))) + +(defmethod to-vampir ((obj fork) values) + "Copy input n intput bits into 2*n output bits" + (append values values)) + +(defmethod to-vampir ((obj parallel) values) + "Take n + m bits, execute car the n bits and cadr on the m bits and + concat the results from car and cadr" + (let* ((car (mcar obj)) + (cadr (mcadr obj)) + (cx (dom car)) + (inp1 (subseq values 0 cx)) + (inp2 (subseq values cx))) + (append (to-vampir car inp1) + (to-vampir cadr inp2)))) + +(defmethod to-vampir ((obj swap) values) + "Turn n + m bits into m + n bits by swapping" + (let ((n (mcar obj))) + (append (subseq values (1+ n)) + (subseq values 0 (1+ n))))) + +(defmethod to-vampir ((obj one) values) + "Produce a bitvector of length 1 containing 1" + (declare (ignore values)) + (list (vamp:make-constant :const 1))) + +(defmethod to-vampir ((obj zero) values) + "Produce a bitvector of length 1 containing 0" + (declare (ignore values)) + (list (vamp:make-constant :const 0))) + +(defmethod to-vampir ((obj ident) values) + "turn n bits into n bits by doing nothing" + values) + +(defmethod to-vampir ((obj drop) values) + "turn n bits into an empty bitvector" + (declare (ignore values)) + nil) + +(defmethod to-vampir ((obj branch) values) + "Look at the first bit. + + If its 1, run f on the remaining bits. + + If its 0, run g on the remaining bits." + (let ((x (car values)) + (xs (cdr values)) + (f (mcar obj)) + (g (mcadr obj)) + (one (vamp:make-constant :const 1))) + (mapcar (lambda (f-elem g-elem) + (infix-creation :+ + (infix-creation :* (infix-creation :- one x) f-elem) + (infix-creation :* x g-elem))) + (to-vampir f xs) + (to-vampir g xs)))) diff --git a/src/entry/package.lisp b/src/entry/package.lisp index 4999f304d..787ae3b58 100644 --- a/src/entry/package.lisp +++ b/src/entry/package.lisp @@ -4,6 +4,7 @@ (defpackage #:geb.entry (:documentation "Entry point for the geb codebase") (:local-nicknames (#:poly #:geb.poly) + (#:bitc #:geb.bitc) (:lambda :geb.lambda)) (:use #:serapeum #:common-lisp))) diff --git a/src/geb/package.lisp b/src/geb/package.lisp index 0d68f27e4..3d76001f9 100644 --- a/src/geb/package.lisp +++ b/src/geb/package.lisp @@ -6,7 +6,7 @@ (defpackage #:geb.main (:documentation "Gödel, Escher, Bach categorical model") (:use #:common-lisp #:serapeum #:geb.mixins #:geb.utils #:geb.spec) - (:local-nicknames (#:poly #:geb.poly.spec)) + (:local-nicknames (#:poly #:geb.poly.spec) (#:bitc #:geb.bitc.spec)) (:shadowing-import-from #:geb.spec :left :right :prod :case) (:export :prod :case :mcar :mcadr :mcaddr :mcdr :name :func :obj :dom :codom))) @@ -48,7 +48,7 @@ (defpackage #:geb.trans (:documentation "Gödel, Escher, Bach categorical model") (:use #:common-lisp #:serapeum #:geb.mixins #:geb.utils #:geb.spec #:geb.main) - (:local-nicknames (#:poly #:geb.poly.spec)) + (:local-nicknames (#:poly #:geb.poly.spec) (#:bitc #:geb.bitc.spec)) (:shadowing-import-from #:geb.spec :left :right :prod :case) (:export :prod :case :mcar :mcadr :mcaddr :mcdr :name :func :obj))) @@ -58,7 +58,8 @@ "These cover various conversions from @GEB-SUBSTMORPH and @GEB-SUBSTMU into other categorical data structures." (to-poly pax:generic-function) - (to-circuit pax:function)) + (to-circuit pax:function) + (to-bitc pax:generic-function)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; bool module diff --git a/src/geb/trans.lisp b/src/geb/trans.lisp index 2abfe4e83..73fe38787 100644 --- a/src/geb/trans.lisp +++ b/src/geb/trans.lisp @@ -5,6 +5,9 @@ (defgeneric to-poly (morphism) (:documentation "Turns a @GEB-SUBSTMORPH into a POLY:POLY")) +(defgeneric to-bitc (morphism) + (:documentation "Turns a @GEB-SUBSTMORPH into a bitc:BITC")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Morph to Poly Implementation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -78,3 +81,110 @@ "Turns a @GEB-SUBSTMORPH to a Vamp-IR Term" (assure geb.vampir.spec:statement (geb.poly:to-circuit (to-poly obj) name))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Morph to Bitc Implementation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod bitwidth ((obj )) + (typecase-of substobj obj + (so0 0) + (so1 0) + (coprod (+ 1 (max (bitwidth (mcar obj)) (bitwidth (mcadr obj))))) + (prod (+ (bitwidth (mcar obj)) (bitwidth (mcadr obj)))) + (otherwise (subclass-responsibility obj)))) + +(defmethod to-bitc ((obj )) + (typecase-of substmorph obj + (substobj + (bitc:ident (bitwidth obj))) + (comp + (bitc:compose (to-bitc (mcar obj)) + (to-bitc (mcadr obj)))) + ;; This should never occure, but if it does, it produces a + ;; constant morphism onto an all 0s list + (init + (apply #'bitc:parallel (zero-list (bitwidth (mcar obj))))) + ;; Terminal maps any bit-list onto the empty bit-list + (terminal + (bitc:drop (bitwidth (mcar obj)))) + + ;; Inject-left x -> x + y tags the x with a 0, indicating left, + ;; and pads the encoded x with as many zeros as would be needed + ;; to store either an x or a y. + (inject-left + (let ((car-width (bitwidth (mcar obj))) + (cadr-width (bitwidth (mcadr obj)))) + (apply #'bitc:parallel + (append (list bitc:zero (bitc:ident car-width)) + (zero-list (padding-bits cadr-width + car-width)))))) + ;; Inject-right y -> x + y tags the y with a 1, indicating right, + ;; and pads the encoded y with as many zeros as would be needed + ;; to store either an x or a y. + (inject-right + (let ((car-width (bitwidth (mcar obj))) + (cadr-width (bitwidth (mcadr obj)))) + (apply #'bitc:parallel + (append (list bitc:one (bitc:ident cadr-width)) + (zero-list (padding-bits car-width + cadr-width)))))) + + ;; Case translates directly into a branch. The sub-morphisms of + ;; case are padded with drop so they have the same input lengths. + (case + (let ((car-width (bitwidth (dom (mcar obj)))) + (cadr-width (bitwidth (dom (mcadr obj))))) + (bitc:branch (bitc:parallel (to-bitc (mcar obj)) + (bitc:drop + (padding-bits cadr-width car-width))) + (bitc:parallel (to-bitc (mcadr obj)) + (bitc:drop + (padding-bits car-width cadr-width)))))) + ;; project-left just drops any bits not being used to encode the + ;; first component. + (project-left + (bitc:parallel (bitc:ident (bitwidth (mcar obj))) + (bitc:drop (bitwidth (mcadr obj))))) + + ;; project-right just drops any bits not being used to encode the + ;; second component. + (project-right + (bitc:parallel (bitc:drop (bitwidth (mcar obj))) + (bitc:ident (bitwidth (mcadr obj))))) + + ;; Pair will copy the input and run the encoded morphisms in pair + ;; on the two copied subvetors. + (pair + (bitc:compose (bitc:parallel (to-bitc (mcar obj)) (to-bitc (mcdr obj))) + (bitc:fork (bitwidth (dom (mcar obj)))))) + ;; a * (b + c) will be encoded as [a] [0 or 1] [b or c]. By + ;; swapping the [0 or 1] with [a], we get an encoding for (a * b) + ;; + (a * c). + (distribute + (bitc:parallel (bitc:swap (bitwidth (mcar obj)) 1) + (bitc:ident (max (bitwidth (mcadr obj)) + (bitwidth (mcaddr obj)))))) + (otherwise (subclass-responsibility obj)))) + +(defun zero-list (length) + (make-list length :initial-element bitc:zero)) + +(-> padding-bits ((integer 0) (integer 0)) (integer 0)) +(defun padding-bits (number number2) + " +```lisp +(max number number2) +``` +is the bits needed to store NUMBER or NUMBER2 + +Thus if we want to calculate the number of padding bits needed then we +should calculate + +```lisp +(- (max number number2) number2) +``` + +We use an optimized version in actual code, which happens to compute the same result" + (max (- number number2) 0)) diff --git a/src/specs/bitc-printer.lisp b/src/specs/bitc-printer.lisp new file mode 100644 index 000000000..186671ba8 --- /dev/null +++ b/src/specs/bitc-printer.lisp @@ -0,0 +1,26 @@ +(in-package #:geb.bitc.spec) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Subst Constructor Printer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; we are going to be super lazy about this, just make a format +(defmacro easy-printer (class-name) + `(defmethod print-object ((obj ,class-name) stream) + (format stream "~A" + (cons ',class-name + (mapcar #'cdr (geb.mixins:to-pointwise-list obj)))))) + +(easy-printer compose) +(easy-printer fork) +(easy-printer parallel) +(easy-printer swap) +(easy-printer one) +(easy-printer zero) +(easy-printer ident) +(easy-printer drop) +(easy-printer branch) + +(defmethod print-object ((obj ident) stream) + (print-unreadable-object (obj stream :type nil :identity nil) + (format stream "IDENT"))) diff --git a/src/specs/bitc.lisp b/src/specs/bitc.lisp new file mode 100644 index 000000000..987c69d68 --- /dev/null +++ b/src/specs/bitc.lisp @@ -0,0 +1,119 @@ +(in-package #:geb.bitc.spec) + +(deftype bitc () + `(or compose fork parallel swap one zero ident drop branch)) + +(defclass (geb.mixins:direct-pointwise-mixin cat-morph) ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Constructor Morphisms for Bits (Objects are just natural numbers) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass compose () + ((mcar :initarg :mcar + :accessor mcar + :documentation "") + (mcadr :initarg :mcadr + :accessor mcadr + :documentation ""))) + +(defclass fork () + ((mcar :initarg :mcar + :accessor mcar + :documentation ""))) + +(defclass parallel () + ((mcar :initarg :mcar + :accessor mcar + :documentation "") + (mcadr :initarg :mcadr + :accessor mcadr + :documentation ""))) + +(defclass swap () + ((mcar :initarg :mcar + :accessor mcar + :documentation "") + (mcadr :initarg :mcadr + :accessor mcadr + :documentation ""))) + +(defclass one () + ()) + +(defclass zero () + ()) + +(defclass ident () + ((mcar :initarg :mcar + :accessor mcar + :documentation ""))) + +(defclass drop () + ((mcar :initarg :mcar + :accessor mcar + :documentation ""))) + +(defclass branch () + ((mcar :initarg :mcar + :accessor mcar + :documentation "") + (mcadr :initarg :mcadr + :accessor mcadr + :documentation ""))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Constructors +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro make-multi (constructor) + `(defun ,constructor (mcar mcadr &rest args) + ,(format nil "Creates a multiway constructor for [~A]" constructor) + (reduce (lambda (x y) + (make-instance ',constructor :mcar x :mcadr y)) + (list* mcar mcadr args) + :from-end t))) + +(make-multi parallel) +(make-multi compose) + +(defun fork (mcar) + "FORK ARG1" + (make-instance 'fork :mcar mcar)) + +(defun swap (mcar mcadr) + "swap ARG1 and ARG2" + (make-instance 'swap :mcar mcar :mcadr mcadr)) + +(serapeum:def one + (make-instance 'one)) + +(serapeum:def zero + (make-instance 'zero)) + +(defun ident (mcar) + "ident ARG1" + (make-instance 'ident :mcar mcar)) + +(defun drop (mcar) + "drop ARG1" + (make-instance 'drop :mcar mcar)) + +(defun branch (mcar mcadr) + "branch with ARG1 or ARG2" + (make-instance 'branch :mcar mcar :mcadr mcadr)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Pattern Matching +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Ι don't do multi way pattern matching yet :( +(make-pattern compose mcar mcadr) +(make-pattern fork mcar) +(make-pattern parallel mcar mcadr) +(make-pattern swap mcar mcadr) +(make-pattern ident mcar) +(make-pattern drop mcar) +(make-pattern branch mcar mcadr) +(make-pattern one) +(make-pattern zero) diff --git a/src/specs/package.lisp b/src/specs/package.lisp index 7c7105964..ccb8c630c 100644 --- a/src/specs/package.lisp +++ b/src/specs/package.lisp @@ -9,6 +9,12 @@ (:shadow :+ :* :/ :- :mod) (:use #:geb.utils #:cl))) +(muffle-package-variance + (defpackage #:geb.bitc.spec + (:export :dom :codom) + (:shadow :drop :fork) + (:use #:geb.utils #:cl #:geb.mixins))) + ;; please document this later. (muffle-package-variance (uiop:define-package #:geb.lambda.spec @@ -90,6 +96,39 @@ constructors" (if-zero pax:function) (if-lt pax:function)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Geb Bits Package Documentation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package :geb.bitc.spec) + +(pax:defsection @bitc (:title "Bits Types") + "This section covers the types of things one can find in the [BITS] +constructors" + (bitc pax:type) + ( pax:class) + (compose pax:class) + (fork pax:class) + (parallel pax:class) + (swap pax:class) + (one pax:class) + (zero pax:class) + (ident pax:class) + (drop pax:class) + (branch pax:class)) + +(pax:defsection @bitc-constructors (:title "Bits (Boolean Circuit) Constructors") + "Every accessor for each of the CLASS's found here are from @GEB-ACCESSORS" + (compose pax:function) + (fork pax:function) + (parallel pax:function) + (swap pax:function) + (one pax:symbol-macro) + (zero pax:symbol-macro) + (ident pax:function) + (drop pax:function) + (branch pax:function)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Geb lambda Package Documentation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/specs/poly-printer.lisp b/src/specs/poly-printer.lisp index 345e1f81c..5cacdd524 100644 --- a/src/specs/poly-printer.lisp +++ b/src/specs/poly-printer.lisp @@ -40,9 +40,9 @@ ;; we are going to be super lazy about this, just make a format (defmacro easy-printer (class-name) `(defmethod print-object ((obj ,class-name) stream) - (print-object (cons ',class-name - (mapcar #'cdr (geb.mixins:to-pointwise-list obj))) - stream))) + (format stream "~A" + (cons ',class-name + (mapcar #'cdr (geb.mixins:to-pointwise-list obj)))))) (easy-printer +) (easy-printer -) diff --git a/test/bitc.lisp b/test/bitc.lisp new file mode 100644 index 000000000..a55c2a110 --- /dev/null +++ b/test/bitc.lisp @@ -0,0 +1,21 @@ +(in-package :geb-test) + +(define-test geb-bitc :parent geb-test-suite) + +(def test-circuit-1 + (bitc:to-circuit + (bitc:compose (bitc:branch + (bitc:parallel (bitc:compose (bitc:parallel bitc:zero + (bitc:ident 0)) + (bitc:drop 1)) + (bitc:ident 0)) + (bitc:parallel (bitc:parallel (bitc:ident 1) + (bitc:drop 0)) + (bitc:ident 0))) + (bitc:parallel (bitc:swap 1 1) + (bitc:ident 0))) + :tc_1)) + +(define-test vampir-converter + :parent geb-bitc + (of-type geb.vampir.spec:alias test-circuit-1)) diff --git a/test/geb.lisp b/test/geb.lisp index 453c87257..dc7757658 100644 --- a/test/geb.lisp +++ b/test/geb.lisp @@ -102,6 +102,8 @@ (def test-poly-2 (geb:to-poly test-morph-2)) +(def test-bitc-2 (geb:to-bitc test-morph-2)) + (def test-circuit-2 (geb:to-circuit test-morph-2 :tc_2)) (define-test vampir-test-2 diff --git a/test/package.lisp b/test/package.lisp index 60885f89d..229c7a564 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -4,6 +4,7 @@ (:shadowing-import-from :serapeum :true) (:shadow :value :children) (:local-nicknames (#:poly #:geb.poly) + (#:bitc #:geb.bitc) (#:lambda #:geb.lambda)) (:use #:geb.common #:parachute))