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

KindCoveredAll%
expression76139 54.7
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.spec)
2
 
3
 (defclass <substobj> (<substmorph> direct-pointwise-mixin meta-mixin cat-obj) ()
4
   (:documentation
5
    "the class corresponding to SUBSTOBJ. See GEB-DOCS/DOCS:@OPEN-CLOSED"))
6
 (deftype substobj ()
7
   `(or prod coprod so0 so1))
8
 
9
 (deftype realized-object ()
10
   "A realized object that can be sent into.
11
 
12
 Lists represent [PROD][class] in the [\\<SUBSTOBJ\\>][class] category
13
 
14
 [LEFT][class] and [RIGHT][class] represents realized values for [COPROD][class]
15
 
16
 Lastly [SO1][class] and [SO0][class] represent the proper class"
17
   `(or list                             ; product
18
        left
19
        right
20
        so1
21
        so0))
22
 
23
 ;; we say that id doesn't exist, as we don't need the tag. If we find
24
 ;; that to ill typed (substobj is a substmorph as far as type checking
25
 ;; is concerned without an explicit id constrcutor), then we can
26
 ;; include it and remove it from the or type here.
27
 
28
 (defclass <substmorph> (direct-pointwise-mixin meta-mixin cat-morph) ()
29
   (:documentation
30
    "the class type corresponding to SUBSTMORPH. See GEB-DOCS/DOCS:@OPEN-CLOSED"))
31
 (deftype substmorph ()
32
   "The morphisms of the [SUBSTMORPH][type] category"
33
   `(or substobj
34
        comp init terminal case pair distribute
35
        inject-left inject-right
36
        project-left project-right))
37
 
38
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39
 ;; Subst Constructor Objects
40
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
41
 
42
 ;; these could be keywords, but maybe in the future not?
43
 (defclass so0 (<substobj>)
44
   ()
45
   (:documentation
46
    "The Initial Object. This is sometimes known as the
47
 [VOID](https://en.wikipedia.org/wiki/Void_type) type.
48
 
49
 the formal grammar of [SO0][class] is
50
 
51
 ```lisp
52
 so0
53
 ```
54
 
55
 where [SO0][class] is `THE` initial object.
56
 
57
 Example
58
 
59
 ```lisp
60
 ```
61
 "
62
    "The Initial/Void Object"))
63
 
64
 (defclass so1 (<substobj>)
65
   ()
66
   (:documentation
67
    "The Terminal Object. This is sometimes referred to as the
68
 [Unit](https://en.wikipedia.org/wiki/Unit_type) type.
69
 
70
 the formal grammar or [SO1][class] is
71
 
72
 ```lisp
73
 so1
74
 ```
75
 
76
 where [SO1][class] is `THE` terminal object
77
 
78
 Example
79
 
80
 ```lisp
81
 (coprod so1 so1)
82
 ```
83
 
84
 Here we construct [GEB-BOOL:BOOL] by simply stating that we have the
85
 terminal object on either side, giving us two possible ways to fill
86
 the type.
87
 
88
 ```lisp
89
 (->left so1 so1)
90
 
91
 (->right so1 so1)
92
 ```
93
 
94
 where applying [->LEFT] gives us the left unit, while [->RIGHT] gives
95
 us the right unit."))
96
 
97
 ;; please make better names and documentation strings!
98
 
99
 (defclass prod (<substobj>)
100
   ((mcar :initarg :mcar
101
          :accessor mcar
102
          :documentation "")
103
    (mcadr :initarg :mcadr
104
           :accessor mcadr
105
           :documentation ""))
106
   (:documentation
107
    "The [PRODUCT][PROD class] object. Takes two CAT-OBJ values that
108
 get put into a pair.
109
 
110
 The formal grammar of [PRODUCT][PROD class] is
111
 
112
 ```lisp
113
 (prod mcar mcadr)
114
 ```
115
 
116
 where [PROD][class] is the constructor, [MCAR] is the left value of the
117
 product, and [MCADR] is the right value of the product.
118
 
119
 Example:
120
 
121
 ```lisp
122
 (geb-gui::visualize (prod geb-bool:bool geb-bool:bool))
123
 ```
124
 
125
 Here we create a product of two [GEB-BOOL:BOOL] types."))
126
 
127
 (defclass coprod (<substobj>)
128
   ((mcar :initarg :mcar
129
          :accessor mcar
130
          :documentation "")
131
    (mcadr :initarg :mcadr
132
           :accessor mcadr
133
           :documentation ""))
134
   (:documentation
135
    "the [CO-PRODUCT][COPROD class] object. Takes CAT-OBJ values that
136
 get put into a choice of either value.
137
 
138
 The formal grammar of [PRODUCT][PROD class] is
139
 
140
 ```lisp
141
 (coprod mcar mcadr)
142
 ```
143
 
144
 Where [CORPOD][class] is the constructor, [MCAR] is the left choice of
145
 the sum, and [MCADR] is the right choice of the sum.
146
 
147
 Example:
148
 
149
 ```lisp
150
 (geb-gui::visualize (coprod so1 so1))
151
 ```
152
 
153
 Here we create the boolean type, having a choice between two unit
154
 values."))
155
 
156
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
157
 ;; Subst Morphism Objects
158
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159
 
160
 (defclass functor (<substmorph>)
161
   ((obj :initarg :obj
162
         :accessor obj)
163
    (func :initarg :func
164
          :accessor func)))
165
 
166
 (defclass comp (<substmorph>)
167
   ((mcar :initarg :mcar
168
          :accessor mcar
169
          :type cat-morph
170
          :documentation "The first composed morphism")
171
    (mcadr :initarg :mcadr
172
           :type cat-morph
173
           :accessor mcadr
174
           :documentation "the second morphism"))
175
   (:documentation
176
    "The composition morphism. Takes two CAT-MORPH values that get
177
 applied in standard composition order.
178
 
179
 The formal grammar of [COMP][class] is
180
 
181
 ```lisp
182
 (comp mcar mcadr)
183
 ```
184
 
185
 which may be more familiar as
186
 
187
 ```haskell
188
 g 。f
189
 ```
190
 
191
 Where [COMP][class]\\( 。\\) is the constructor, [MCAR]\\(g\\) is the second morphism
192
 that gets applied, and [MCADR]\\(f\\) is the first morphism that gets
193
 applied.
194
 
195
 Example:
196
 
197
 ```lisp
198
 (geb-gui::visualize
199
  (comp
200
   (<-right so1 geb-bool:bool)
201
   (pair (<-left so1 geb-bool:bool)
202
         (<-right so1 geb-bool:bool))))
203
 ```
204
 
205
 In this example we are composing two morphisms. the first morphism
206
 that gets applied ([PAIR] ...) is the identity function on the
207
 type ([PROD][class] [SO1][class] [GEB-BOOL:BOOL]), where we pair the
208
 [left projection](PROJECT-LEFT) and the [right
209
 projection](PROJECT-RIGHT), followed by taking the [right
210
 projection](PROJECT-RIGHT) of the type.
211
 
212
 Since we know ([COMP][class] f id) is just f per the laws of category
213
 theory, this expression just reduces to
214
 
215
 ```lisp
216
 (<-right so1 geb-bool:bool)
217
 ```"))
218
 
219
 (defclass init (<substmorph>)
220
   ((obj :initarg :obj
221
         :accessor obj
222
         :type cat-obj
223
         :documentation ""))
224
   (:documentation
225
    "The [INITIAL][INIT class] Morphism, takes any [CAT-OBJ] and
226
 creates a moprhism from [SO0][class] (also known as void) to the object given.
227
 
228
 The formal grammar of [INITIAL][INIT class] is
229
 
230
 ```lisp
231
 (init obj)
232
 ```
233
 
234
 where [INIT][class] is the constructor. [OBJ] is the type of object
235
 that will be conjured up from [SO0][class], when the morphism is
236
 applied onto an object.
237
 
238
 Example:
239
 
240
 ```lisp
241
 (init so1)
242
 ```
243
 
244
 In this example we are creating a unit value out of void."))
245
 
246
 (defclass terminal (<substmorph>)
247
   ((obj :initarg :obj
248
         :accessor obj
249
         :type cat-obj
250
         :documentation ""))
251
   (:documentation
252
    "The [TERMINAL][class] morphism, Takes any [CAT-OBJ] and creates a
253
 morphism from that object to [SO1][class] (also known as unit).
254
 
255
 The formal grammar of [TERMINAL][class] is
256
 
257
 ```lisp
258
 (terminal obj)
259
 ```
260
 
261
 where [TERMINAL][class] is the constructor. [OBJ] is the type of object that
262
 will be mapped to [SO1][class], when the morphism is applied onto an
263
 object.
264
 
265
 Example:
266
 
267
 ```lisp
268
 (terminal (coprod so1 so1))
269
 
270
 (geb-gui::visualize (terminal (coprod so1 so1)))
271
 
272
 (comp value (terminal (codomain value)))
273
 
274
 (comp true (terminal bool))
275
 ```
276
 
277
 In the first example, we make a morphism from the corpoduct of
278
 [SO1][class] and [SO1][class] (essentially [GEB-BOOL:BOOL]) to
279
 [SO1][class].
280
 
281
 In the third example we can proclaim a constant function by ignoring
282
 the input value and returning a morphism from unit to the desired type.
283
 
284
 The fourth example is taking a [GEB-BOOL:BOOL] and returning [GEB-BOOL:TRUE]."))
285
 
286
 ;; Please name all of these better plz
287
 
288
 (defclass inject-left (<substmorph>)
289
   ((mcar :initarg :mcar
290
          :accessor mcar
291
          :type cat-obj
292
          :documentation "")
293
    (mcadr :initarg :mcadr
294
           :accessor mcadr
295
           :type cat-obj
296
           :documentation ""))
297
   (:documentation
298
    "The left injection morphism. Takes two CAT-OBJ values. It is
299
 the dual of INJECT-RIGHT
300
 
301
 The formal grammar is
302
 
303
 ```lisp
304
 (->left mcar mcadr)
305
 ```
306
 
307
 Where [->LEFT] is the constructor, [MCAR] is the value being injected into
308
 the coproduct of [MCAR] + [MCADR], and the [MCADR] is just the type for
309
 the unused right constructor.
310
 
311
 Example:
312
 
313
 ```lisp
314
 (geb-gui::visualize (->left so1 geb-bool:bool))
315
 
316
 (comp
317
  (mcase geb-bool:true
318
         geb-bool:not)
319
  (->left so1 geb-bool:bool))
320
 
321
 ```
322
 
323
 In the second example, we inject a term with the shape SO1 into a pair
324
 with the shape ([SO1][class] × [GEB-BOOL:BOOL]), then we use MCASE to denote a
325
 morphism saying. `IF` the input is of the shape [SO1], then give us True,
326
 otherwise flip the value of the boolean coming in."))
327
 
328
 (defclass inject-right (<substmorph>)
329
   ((mcar :initarg :mcar
330
          :accessor mcar
331
          :type cat-obj
332
          :documentation "")
333
    (mcadr :initarg :mcadr
334
           :accessor mcadr
335
           :type cat-obj
336
           :documentation ""))
337
   (:documentation
338
    "The right injection morphism. Takes two CAT-OBJ values. It is
339
 the dual of INJECT-LEFT
340
 
341
 The formal grammar is
342
 
343
 ```lisp
344
 (->right mcar mcadr)
345
 ```
346
 
347
 Where ->RIGHT is the constructor, [MCADR] is the value being injected into
348
 the coproduct of [MCAR] + [MCADR], and the [MCAR] is just the type for
349
 the unused left constructor.
350
 
351
 Example:
352
 
353
 ```lisp
354
 (geb-gui::visualize (->right so1 geb-bool:bool))
355
 
356
 (comp
357
  (mcase geb-bool:true
358
         geb-bool:not)
359
  (->right so1 geb-bool:bool))
360
 
361
 ```
362
 
363
 In the second example, we inject a term with the shape [GEB-BOOL:BOOL]
364
 into a pair with the shape ([SO1][class] × [GEB-BOOL:BOOL]), then we use
365
 [MCASE] to denote a morphism saying. IF the input is of the shape [SO1],
366
 then give us True, otherwise flip the value of the boolean coming in."))
367
 
368
 (defclass case (<substmorph>)
369
   ((mcar :initarg :mcar
370
          :accessor mcar
371
          :type cat-morph
372
          :documentation "The morphism that gets applied on the left coproduct")
373
    (mcadr :initarg :mcadr
374
           :accessor mcadr
375
           :type cat-morph
376
           :documentation "The morphism that gets applied on the right coproduct"))
377
   (:documentation
378
    "Eliminates coproducts. Namely Takes two CAT-MORPH values, one
379
 gets applied on the left coproduct while the other gets applied on the
380
 right coproduct. The result of each CAT-MORPH values must be
381
 the same.
382
 
383
 The formal grammar of [CASE][class] is:
384
 
385
 ```lisp
386
 (mcase mcar mcadr)
387
 ```
388
 
389
 Where [MCASE] is the constructor, [MCAR] is the morphism that gets
390
 applied to the left coproduct, and [MCADR] is the morphism that gets
391
 applied to the right coproduct.
392
 
393
 Example:
394
 
395
 ```lisp
396
 (comp
397
  (mcase geb-bool:true
398
         geb-bool:not)
399
  (->right so1 geb-bool:bool))
400
 ```
401
 
402
 In the second example, we inject a term with the shape [GEB-BOOL:BOOL]
403
 into a pair with the shape ([SO1][class] × [GEB-BOOL:BOOL]), then we use
404
 [MCASE] to denote a morphism saying. IF the input is of the shape [SO1],
405
 then give us True, otherwise flip the value of the boolean coming in."))
406
 
407
 (defclass pair (<substmorph>)
408
   ((mcar :initarg :mcar
409
          :accessor mcar
410
          :type cat-morph
411
          :documentation "The left morphism")
412
    (mcdr :initarg :mcdr
413
          :accessor mcdr
414
          :type cat-morph
415
          :documentation "The right morphism"))
416
   (:documentation
417
    "Introduces products. Namely Takes two CAT-MORPH values. When
418
 the PAIR morphism is applied on data, these two [CAT-MORPH]'s are
419
 applied to the object, returning a pair of the results
420
 
421
 The formal grammar of constructing an instance of pair is:
422
 
423
 ```
424
 (pair mcar mcdr)
425
 ```
426
 
427
 where PAIR is the constructor, MCAR is the left morphism, and MCDR is
428
 the right morphism
429
 
430
 Example:
431
 
432
 ```lisp
433
 (pair (<-left so1 geb-bool:bool)
434
       (<-right so1 geb-bool:bool))
435
 
436
 (geb-gui::visualize (pair (<-left so1 geb-bool:bool)
437
                           (<-right so1 geb-bool:bool)))
438
 ```
439
 
440
 Here this pair morphism takes the pair SO1 × GEB-BOOL:BOOL, and
441
 projects back the left field [SO1][class] as the first value of the pair and
442
 projects back the GEB-BOOL:BOOL field as the second values."))
443
 
444
 (defclass project-left (<substmorph>)
445
   ((mcar :initarg :mcar
446
          :accessor mcar
447
          :type cat-obj
448
          :documentation "")
449
    (mcadr :initarg :mcadr
450
           :accessor mcadr
451
           :type cat-obj
452
           :documentation ""))
453
   (:documentation
454
    "The [LEFT PROJECTION][PROJECT-LEFT class]. Takes two
455
 [CAT-MORPH] values. When the [LEFT PROJECTION][PROJECT-LEFT
456
 class] morphism is then applied, it grabs the left value of a product,
457
 with the type of the product being determined by the two
458
 [CAT-MORPH] values given.
459
 
460
 the formal grammar of a [PROJECT-LEFT][class] is:
461
 
462
 ```lisp
463
 (<-left mcar mcadr)
464
 ```
465
 
466
 Where [<-LEFT] is the constructor, [MCAR] is the left type of the
467
 [PRODUCT][class] and [MCADR] is the right type of the [PRODUCT][class].
468
 
469
 Example:
470
 
471
 ```lisp
472
 (geb-gui::visualize
473
   (<-left geb-bool:bool (prod so1 geb-bool:bool)))
474
 ```
475
 
476
 In this example, we are getting the left [GEB-BOOL:BOOL] from a
477
 product with the shape
478
 
479
 ([GEB-BOOL:BOOL][] [×][PROD class] [SO1][class] [×][PROD class] [GEB-BOOL:BOOL])"))
480
 
481
 (defclass project-right (<substmorph>)
482
   ((mcar :initarg :mcar
483
          :accessor mcar
484
          :type cat-obj
485
          :documentation "")
486
    (mcadr :initarg :mcadr
487
           :accessor mcadr
488
           :type cat-obj
489
           :documentation "Right projection (product elimination)"))
490
   (:documentation "The [RIGHT PROJECTION][PROJECT-RIGHT class]. Takes two
491
 [CAT-MORPH] values. When the [RIGHT PROJECTION][PROJECT-RIGHT
492
 class] morphism is then applied, it grabs the right value of a product,
493
 with the type of the product being determined by the two
494
 [CAT-MORPH] values given.
495
 
496
 
497
 the formal grammar of a [PROJECT-RIGHT][class] is:
498
 
499
 ```lisp
500
 (<-right mcar mcadr)
501
 ```
502
 
503
 Where [<-RIGHT] is the constructor, [MCAR] is the right type of the
504
 [PRODUCT][class] and [MCADR] is the right type of the [PRODUCT][class].
505
 
506
 Example:
507
 
508
 ```lisp
509
 (geb-gui::visualize
510
  (comp (<-right so1 geb-bool:bool)
511
        (<-right geb-bool:bool (prod so1 geb-bool:bool))))
512
 ```
513
 
514
 In this example, we are getting the right [GEB-BOOL:BOOL] from a
515
 product with the shape
516
 
517
 ([GEB-BOOL:BOOL][] [×][PROD class] [SO1][class] [×][PROD class] [GEB-BOOL:BOOL])"))
518
 
519
 (defclass distribute (<substmorph>)
520
   ((mcar :initarg :mcar
521
          :accessor mcar
522
          :type cat-obj
523
          :documentation "")
524
    (mcadr :initarg :mcadr
525
           :accessor mcadr
526
           :type cat-obj
527
           :documentation "")
528
    (mcaddr :initarg :mcaddr
529
            :accessor mcaddr
530
            :type cat-obj
531
            :documentation ""))
532
   (:documentation "The distributive law"))
533
 
534
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
535
 ;; realized object
536
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
537
 
538
 (defclass left (direct-pointwise-mixin)
539
   ((obj :initarg :obj
540
         :accessor obj
541
         :documentation "The object that is being injected left")))
542
 
543
 (defclass right (direct-pointwise-mixin)
544
   ((obj :initarg :obj
545
         :accessor obj
546
         :documentation "The object that is being injected left")))
547
 
548
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
549
 ;; Constructors for the base types
550
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
551
 
552
 ;; this is considered bad style, one should call their constructors
553
 ;; make, but it does not matter
554
 
555
 (defun so1 ()
556
   "Creates a fresh so1. Useful for aliases"
557
   (make-instance 'so1))
558
 
559
 (defun so0 ()
560
   "Creates a fresh so0. Useful for aliases"
561
   (make-instance 'so0))
562
 
563
 (defparameter *so0* (make-instance 'so0)
564
   "The Initial Object")
565
 (def so0 *so0*
566
   "The Initial Object")
567
 (defparameter *so1* (make-instance 'so1)
568
   "The Terminal Object")
569
 (def so1 *so1*
570
   "The Terminal Object")
571
 
572
 (-> left (t) left)
573
 (defun left (obj)
574
   (assure left
575
     (make-instance 'left :obj obj)))
576
 
577
 (-> right (t) right)
578
 (defun right (obj)
579
   (assure right
580
     (make-instance 'right :obj obj)))
581
 
582
 
583
 (-> prod (t t) prod)
584
 (defun prod (car cadr)
585
   (values
586
    (make-instance 'prod :mcar car :mcadr cadr)))
587
 
588
 (-> coprod (t t) coprod)
589
 (defun coprod (car cadr)
590
   (values
591
    (make-instance 'coprod :mcar car :mcadr cadr)))
592
 
593
 (defmacro alias (name obj)
594
   `(make-alias :name ',name :obj ,obj))
595
 
596
 (-> make-alias (&key (:name symbol) (:obj t)) t)
597
 (defun make-alias (&key name obj)
598
   (geb.mixins:meta-insert obj :alias name)
599
   obj)
600
 
601
 (defun has-aliasp (obj)
602
   (multiple-value-bind (val in-there) (geb.mixins:meta-lookup obj :alias)
603
     (declare (ignore val))
604
     in-there))
605
 
606
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
607
 ;; Constructors for the morphism constructors
608
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
609
 ;; we could type the objects more if wanted
610
 
611
 (-> comp (cat-morph cat-morph &rest cat-morph) comp)
612
 (defun comp (car cadr &rest comps)
613
   (let ((list (list* car cadr comps)))
614
     (mvfoldr (lambda (x acc)
615
                (make-instance 'comp :mcar x :mcadr acc))
616
              (butlast list)
617
              (car (last list)))))
618
 
619
 (-> init (cat-obj) init)
620
 (defun init (obj)
621
   (values
622
    (make-instance 'init :obj obj)))
623
 
624
 (-> terminal (cat-obj) terminal)
625
 (defun terminal (obj)
626
   (values
627
    (make-instance 'terminal :obj obj)))
628
 
629
 (-> ->left (cat-obj cat-obj) inject-left)
630
 (defun ->left (mcar mcadr)
631
   "injects left constructor"
632
   (values
633
    (make-instance 'inject-left :mcar mcar :mcadr mcadr)))
634
 
635
 (-> ->right (cat-obj cat-obj) inject-right)
636
 (defun ->right (mcar mcadr)
637
   "injects right constructor"
638
   (values
639
    (make-instance 'inject-right :mcar mcar :mcadr mcadr)))
640
 
641
 (-> <-left (cat-obj cat-obj) project-left)
642
 (defun <-left (mcar mcadr)
643
   "projects left constructor"
644
   (values
645
    (make-instance 'project-left :mcar mcar :mcadr mcadr)))
646
 
647
 (-> <-right (cat-obj cat-obj) project-right)
648
 (defun <-right (mcar mcadr)
649
   "projects right constructor"
650
   (values
651
    (make-instance 'project-right :mcar mcar :mcadr mcadr)))
652
 
653
 (-> mcase (cat-morph cat-morph) case)
654
 (defun mcase (mcar mcadr)
655
   (values
656
    (make-instance 'case :mcar mcar :mcadr mcadr)))
657
 
658
 (-> pair (cat-morph cat-morph) pair)
659
 (defun pair (mcar mcdr)
660
   (values
661
    (make-instance 'pair :mcar mcar :mcdr mcdr)))
662
 
663
 (-> distribute (cat-obj cat-obj cat-obj) distribute)
664
 (defun distribute (mcar mcadr mcaddr)
665
   (values
666
    (make-instance 'distribute :mcar mcar :mcadr mcadr :mcaddr mcaddr)))
667
 
668
 (defun make-functor (&key obj func)
669
   (make-instance 'functor :func func :obj obj))
670
 
671
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
672
 ;; Extra Accessors
673
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
674
 
675
 (defmethod mcar ((obj terminal))
676
   (obj obj))
677
 
678
 (defmethod mcar ((obj init))
679
   (obj obj))
680
 
681
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
682
 ;; Pattern Matching conveniences
683
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
684
 
685
 ;; less safe than I wanted due to the names can be out of sync, but
686
 ;; w/e I can fix it with a better defclass macro
687
 (make-pattern prod   mcar mcadr)
688
 (make-pattern so1    mcar mcadr)
689
 (make-pattern so0    mcar mcadr)
690
 (make-pattern coprod mcar mcadr)
691
 (make-pattern init          obj)
692
 (make-pattern terminal      obj)
693
 (make-pattern comp          mcar mcadr)
694
 (make-pattern inject-left   mcar mcadr)
695
 (make-pattern inject-right  mcar mcadr)
696
 (make-pattern case          mcar mcadr)
697
 (make-pattern pair          mcar mcdr)
698
 (make-pattern project-left  mcar mcadr)
699
 (make-pattern project-right mcar mcadr)
700
 (make-pattern distribute    mcar mcadr mcaddr)
701
 ������������