Coverage report: /home/runner/work/geb/geb/src/specs/bitc.lisp

KindCoveredAll%
expression1244 27.3
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package #:geb.bitc.spec)
2
 
3
 (deftype bitc ()
4
   `(or compose fork parallel swap one zero ident drop branch))
5
 
6
 (defclass <bitc> (geb.mixins:direct-pointwise-mixin cat-morph) ())
7
 
8
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9
 ;; Constructor Morphisms for Bits (Objects are just natural numbers)
10
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11
 
12
 (defclass compose (<bitc>)
13
   ((mcar :initarg :mcar
14
          :accessor mcar
15
          :documentation "")
16
    (mcadr :initarg :mcadr
17
           :accessor mcadr
18
           :documentation ""))
19
   (:documentation "composes the MCAR and the MCADR"))
20
 
21
 (defclass fork (<bitc>)
22
   ((mcar :initarg :mcar
23
          :accessor mcar
24
          :documentation ""))
25
   (:documentation "Copies the MCAR of length n onto length 2*n by copying its
26
 inputs (MCAR)."))
27
 
28
 (defclass parallel (<bitc>)
29
   ((mcar :initarg :mcar
30
          :accessor mcar
31
          :documentation "")
32
    (mcadr :initarg :mcadr
33
           :accessor mcadr
34
           :documentation ""))
35
   (:documentation
36
    "
37
 ```lisp
38
 (parallel x y)
39
 ```
40
 
41
 constructs a [PARALLEL][class] term where the [MCAR] is `x` and the
42
 [MCADR] is `y`,
43
 
44
 where if
45
 
46
 ```
47
 x : a → b,          y : c → d
48
 -------------------------------
49
 (parallel x y) : a + c → b + d
50
 ```
51
 
52
 then the [PARALLEL][class] will return a function from a and c to b
53
 and d where the [MCAR] and [MCADR] run on subvectors of the input."))
54
 
55
 (defclass swap (<bitc>)
56
   ((mcar :initarg :mcar
57
          :accessor mcar
58
          :documentation "")
59
    (mcadr :initarg :mcadr
60
           :accessor mcadr
61
           :documentation ""))
62
   (:documentation
63
    "
64
 ```lisp
65
 (swap n m)
66
 ```
67
 
68
 binds the [MCAR] to n and [MCADR] to m, where if the input
69
 vector is of length `n + m`, then it swaps the bits, algebraically we
70
 view it as
71
 
72
 ```lisp
73
 (swap n m) : #*b₁...bₙbₙ₊₁...bₙ₊ₘ → #*bₙ₊₁...bₘ₊ₙb₁...bₙ
74
 ```"))
75
 
76
 (defclass one (<bitc>)
77
   ()
78
   (:documentation
79
    "[ONE][class] represents the map from 0 onto 1 producing a vector
80
    with only 1 in it."))
81
 
82
 (defclass zero (<bitc>)
83
   ()
84
   (:documentation
85
    "[ZERO] map from 0 onto 1 producing a vector with only 0 in
86
    it."))
87
 
88
 (defclass ident (<bitc>)
89
   ((mcar :initarg :mcar
90
          :accessor mcar
91
          :documentation ""))
92
   (:documentation
93
    "[IDENT] represents the identity"))
94
 
95
 (defclass drop (<bitc>)
96
   ((mcar :initarg :mcar
97
          :accessor mcar
98
          :documentation ""))
99
   (:documentation
100
    "[DROP] represents the unique morphism from n to 0."))
101
 
102
 (defclass branch (<bitc>)
103
   ((mcar :initarg :mcar
104
          :accessor mcar
105
          :documentation "")
106
    (mcadr :initarg :mcadr
107
           :accessor mcadr
108
           :documentation ""))
109
   (:documentation
110
    "
111
 ```lisp
112
 (branch x y)
113
 ```
114
 
115
 constructs a [BRANCH][class] term where the [MCAR] is `x` and the
116
 [MCADR] is `y`,
117
 
118
 where if
119
 
120
 ```
121
 x : a → b,          y : a → b
122
 -------------------------------
123
 (branch x y) : 1+a → b
124
 ```
125
 
126
 then the [BRANCH] will return a function on the type `1 + a`, where the
127
 1 represents a bit to branch on. If the first bit is `0`, then the
128
 [MCAR] is ran, however if the bit is `1`, then the [MCADR] is ran."))
129
 
130
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
131
 ;; Constructors
132
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
133
 
134
 (defmacro make-multi (constructor)
135
   `(defun ,constructor (mcar mcadr &rest args)
136
      ,(format nil "Creates a multiway constructor for [~A]" constructor)
137
      (reduce (lambda (x y)
138
                (make-instance ',constructor :mcar x :mcadr y))
139
              (list* mcar mcadr args)
140
              :from-end t)))
141
 
142
 (make-multi parallel)
143
 (make-multi compose)
144
 
145
 (defun fork (mcar)
146
   "FORK ARG1"
147
   (make-instance 'fork :mcar mcar))
148
 
149
 (defun swap (mcar mcadr)
150
   "swap ARG1 and ARG2"
151
   (make-instance 'swap :mcar mcar :mcadr mcadr))
152
 
153
 (serapeum:def one
154
   (make-instance 'one))
155
 
156
 (serapeum:def zero
157
   (make-instance 'zero))
158
 
159
 (defun ident (mcar)
160
   "ident ARG1"
161
   (make-instance 'ident :mcar mcar))
162
 
163
 (defun drop (mcar)
164
   "drop ARG1"
165
   (make-instance 'drop :mcar mcar))
166
 
167
 (defun branch (mcar mcadr)
168
   "branch with ARG1 or ARG2"
169
   (make-instance 'branch :mcar mcar :mcadr mcadr))
170
 
171
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
172
 ;; Pattern Matching
173
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
174
 
175
 ;; Ι don't do multi way pattern matching yet :(
176
 (make-pattern compose  mcar mcadr)
177
 (make-pattern fork     mcar)
178
 (make-pattern parallel mcar mcadr)
179
 (make-pattern swap     mcar mcadr)
180
 (make-pattern ident    mcar)
181
 (make-pattern drop     mcar)
182
 (make-pattern branch   mcar mcadr)
183
 (make-pattern one)
184
 (make-pattern zero)
185
 �����������������������������������������������