Coverage report: /home/runner/work/geb/geb/src/seqn/seqn.lisp

KindCoveredAll%
expression256549 46.6
branch928 32.1
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.seqn.main)
2
 
3
 (defun fill-in (num seq)
4
   "Fills in extra inputs on the right with 0-oes"
5
   (geb.utils:apply-n num (lambda (x) (append x (list 0))) seq))
6
 
7
 (defun zero-list (n)
8
   (make-list n :initial-element 0))
9
 
10
 (defun prod-list (l1 l2)
11
   "Takes two lists of same length and gives pointwise product
12
 where first element come from first list and second from second
13
 
14
 ```lisp
15
 SEQN> (prod-list (list 1 2) (list 3 4))
16
 ((1 3) (2 4))
17
 ```"
18
   (mapcar #'list l1 l2))
19
 
20
 (defun seq-max-fill (seq1 seq2)
21
   "Takes two lists, makes them same length by adding 0es on the right
22
 where necessary and takes their pointwise product"
23
   (let ((l1 (length seq1))
24
         (l2 (length seq2)))
25
     (if (< l1 l2)
26
         (prod-list (fill-in (- l2 l1) seq1) seq2)
27
         (prod-list seq1 (fill-in (- l1 l2) seq2)))))
28
 
29
 (defun max-list (lst)
30
   (max (car lst) (cadr lst)))
31
 
32
 (defmethod width ((obj <substobj>))
33
   (typecase-of substobj obj
34
     (so0 (list 0))
35
     (so1 (list 0))
36
     (coprod (cons 1
37
                   (mapcar #'max-list
38
                           (seq-max-fill (width (mcar obj))
39
                                         (width (mcadr obj))))))
40
     (prod (append (width (mcar obj))
41
                   (width (mcadr obj))))
42
     (otherwise (geb.utils:subclass-responsibility obj))))
43
 
44
 (defmethod width ((obj <natobj>))
45
   (typecase-of natobj obj
46
     (nat-width (list (num obj)))
47
     (otherwise (geb.utils:subclass-responsibility obj))))
48
 
49
 (defun inj-coprod-parallel (obj copr)
50
   "takes an width(A) or width(B) already transformed with a width(A+B)
51
 and gives an appropriate injection of (a1,...,an) into
52
 (max (a1, b1), ...., max(an, bn),...) i.e. where the maxes are being
53
 taken during the width operation without filling in of the smaller object"
54
   (let* ((lng (length obj))
55
          (lngcoprod (1- (length copr)))
56
          (dif (- lngcoprod lng))
57
          (cdr (cdr copr)))
58
     (if (= lng lngcoprod)
59
         (drop-width obj cdr)
60
         (composition (drop-width (append obj (zero-list dif))
61
                                  cdr)
62
                      (inj-length-left obj (zero-list dif))))))
63
 
64
 (defmethod dom ((x <seqn>))
65
   "Gives the domain of a morphism in SeqN.
66
 For a less formal desription consult the specs file"
67
   (typecase-of seqn x
68
     (composition      (dom (mcadr x)))
69
     (fork-seq         (mcar x))
70
     (parallel-seq     (append (dom (mcar x)) (dom (mcadr x))))
71
     (id               (mcar x))
72
     (drop-nil         (mcar x))
73
     (remove-right     (append (mcar x) (list 0)))
74
     (remove-left      (cons 0 (mcar x)))
75
     (drop-width       (mcar x))
76
     (inj-length-left  (mcar x))
77
     (inj-length-right (mcadr x))
78
     (inj-size         (list (mcar x)))
79
     (branch-seq       (cons 1 (dom (mcar x))))
80
     (zero-bit         (list 0))
81
     (one-bit          (list 0))
82
     (shift-front      (mcar x))
83
     (seqn-add         (list (mcar x) (mcar x)))
84
     (seqn-subtract    (list (mcar x) (mcar x)))
85
     (seqn-multiply    (list (mcar x) (mcar x)))
86
     (seqn-divide      (list (mcar x) (mcar x)))
87
     (seqn-mod         (list (mcar x) (mcar x)))
88
     (seqn-nat         (list 0))
89
     (seqn-concat      (list (mcar x) (mcadr x)))
90
     (seqn-decompose   (list (mcar x)))
91
     (seqn-eq          (list (mcar x) (mcar x)))
92
     (seqn-lt          (list (mcar x) (mcar x)))
93
     (otherwise (geb.utils:subclass-responsibility x))))
94
 
95
 (defmethod cod ((x <seqn>))
96
   "Gives the codomain of a morphism in SeqN.
97
 For a less formal description consult the specs file"
98
   (typecase-of seqn x
99
     (composition      (cod (mcar x)))
100
     (fork-seq         (append  (mcar x) (mcar x)))
101
     (parallel-seq     (append (cod (mcar x)) (cod (mcadr x))))
102
     (id               (mcar x))
103
     (drop-nil         (list 0))
104
     (remove-right     (mcar x))
105
     (remove-left      (mcar x))
106
     (drop-width       (mcadr x))
107
     (inj-length-left  (append (mcar x) (mcadr x)))
108
     (inj-length-right (append (mcar x) (mcadr x)))
109
     (inj-size         (list (mcadr x)))
110
     (branch-seq       (cod (mcar x)))
111
     (zero-bit         (list 1))
112
     (one-bit          (list 1))
113
     (shift-front      (let ((mcar (mcar x))
114
                             (mcadr (mcadr x)))
115
                         (append (cons (nth (1- mcadr) mcar)
116
                                       (subseq mcar 0 (1- mcadr)))
117
                                 (subseq mcar mcadr))))
118
     (seqn-add         (list (mcar x)))
119
     (seqn-subtract    (list (mcar x)))
120
     (seqn-multiply    (list (mcar x)))
121
     (seqn-divide      (list (mcar x)))
122
     (seqn-nat         (list (mcar x)))
123
     (seqn-mod         (list (mcar x)))
124
     (seqn-concat      (list (+ (mcar x) (mcadr x))))
125
     (seqn-decompose   (list 1 (1- (mcar x))))
126
     (seqn-eq          (list 1 0))
127
     (seqn-lt          (list 1 0))
128
     (otherwise (geb.utils:subclass-responsibility x))))
129
 
130
 (defmethod gapply ((morphism <seqn>) vector)
131
   "Takes a list of vectors of natural numbers and gives out their evaluations.
132
 Currently does not correspond directly to the intended semantics but
133
 is capable of succesfully evaluating all compiled terms"
134
   (etypecase-of seqn morphism
135
     (id               vector)
136
     (composition      (gapply (mcar morphism)
137
                               (gapply (mcadr morphism) vector)))
138
     (parallel-seq     (let ((lng (length (dom (mcar morphism)))))
139
                         (append (gapply (mcar morphism)
140
                                         (subseq vector
141
                                                 0 lng))
142
                                 (gapply (mcadr morphism)
143
                                         (subseq vector
144
                                                 lng)))))
145
     (fork-seq         (append vector vector))
146
     (drop-nil         (list 0))
147
     (remove-right     (butlast vector))
148
     (remove-left      (cdr vector))
149
     (drop-width       vector)
150
     (inj-length-left  (append vector
151
                               (make-list (length (mcadr morphism))
152
                                          :initial-element 0)))
153
     (inj-length-right (append (make-list (length (mcar morphism))
154
                                          :initial-element 0)
155
                               vector))
156
     (inj-size         vector)
157
     (branch-seq       (let ((cdr (cdr vector)))
158
                         (if (= 0 (car vector))
159
                             (gapply (mcar morphism)
160
                                     cdr)
161
                             (gapply (mcadr morphism)
162
                                     cdr))))
163
     (shift-front     (let ((mcadr (1- (mcadr morphism))))
164
                        (append (cons (nth mcadr
165
                                           vector)
166
                                      (subseq vector 0 mcadr))
167
                                (subseq vector (mcadr morphism)))))
168
     (zero-bit         (list 0))
169
     (one-bit          (list  1))
170
     (seqn-add         (list (+ (car vector) (cadr vector))))
171
     (seqn-subtract    (list (- (car vector) (cadr vector))))
172
     (seqn-multiply    (list (* (car vector) (cadr vector))))
173
     (seqn-divide      (list (multiple-value-bind (q)
174
                                 (floor (car vector) (cadr vector)) q)))
175
     (seqn-mod         (list (mod (car vector) (cadr vector))))
176
     (seqn-nat         (list (mcadr morphism)))
177
     (seqn-concat      (list (+ (* (expt 2 (mcadr morphism)) (car vector))
178
                                (cadr vector))))
179
     (seqn-decompose   (let ((car (car vector))
180
                             (exp (expt 2 (1- (mcar morphism)))))
181
                         (if (>= car exp)
182
                             (list 1 (- car exp))
183
                             (list 0 car))))
184
     (seqn-eq          (if (= (car vector) (cadr vector))
185
                           (list 0 0)
186
                           (list 1 0)))
187
     (seqn-lt          (if (< (car vector) (cadr vector))
188
                           (list 0 0)
189
                           (list 1 0)))))
190
 
191
 (defmethod well-defp-cat ((morph <seqn>))
192
   (etypecase-of seqn morph
193
     (composition
194
      (let* ((mcar  (mcar morph))
195
             (mcadr (mcadr morph))
196
             (dom (dom mcar))
197
             (cod (cod mcadr)))
198
        (if (and (well-defp-cat mcar)
199
                 (well-defp-cat mcadr)
200
                 (obj-equalp dom
201
                             cod))
202
            t
203
            (error "Co(Domains) do not match for ~A with domain
204
                                     of MCAR ~A1 and codomain of MCADR ~A2."
205
                   morph cod dom))))
206
     (parallel-seq
207
      (if (and (well-defp-cat (mcar morph))
208
               (well-defp-cat (mcadr morph)))
209
          t
210
          (error "Not well-defined parallel composition ~A" morph)))
211
     (branch-seq
212
      (let* ((mcar (mcar morph))
213
             (mcadr (mcadr morph))
214
             (dom1  (dom mcar))
215
             (dom2  (dom mcadr))
216
             (cod1  (cod mcar))
217
             (cod2  (cod mcadr)))
218
        (if (and (well-defp-cat mcar)
219
                 (well-defp-cat mcadr)
220
                 (obj-equalp dom1 dom2)
221
                 (obj-equalp cod1 cod2))
222
            t
223
            (error "Not a well-defined branching ~A.
224
                                    ~A1 has dom ~a1 and cod ~a2.
225
                                    ~A2 has dom ~a3 and cod ~a4"
226
                   morph mcar dom1 cod1 mcadr dom2 cod2))))
227
     (shift-front
228
      (if (>= (length (mcar morph))
229
              (mcadr morph))
230
          t
231
          (error "Wrong shift-length for ~A" morph)))
232
     ((or id
233
          fork-seq
234
          drop-nil
235
          drop-width
236
          remove-right
237
          remove-left
238
          inj-length-left
239
          inj-length-right
240
          inj-size
241
          zero-bit
242
          one-bit
243
          seqn-add
244
          seqn-multiply
245
          seqn-divide
246
          seqn-subtract
247
          seqn-mod
248
          seqn-nat
249
          seqn-concat
250
          seqn-decompose
251
          seqn-eq
252
          seqn-lt)
253
      t)))