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

KindCoveredAll%
expression112136 82.4
branch22100.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.bitc.main)
2
 
3
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4
 ;; Domain and codomain definitions
5
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6
 
7
 (defmethod dom ((x <bitc>))
8
   "Gives the length of the bit vector the [\\<BITC\\>] moprhism takes"
9
   (typecase-of bitc x
10
     (compose  (dom (mcadr x)))
11
     (fork     (mcar x))
12
     (parallel (+ (dom (mcar x)) (dom (mcadr x))))
13
     (swap     (+ (mcar x) (mcadr x)))
14
     (one      0)
15
     (zero     0)
16
     (ident    (mcar x))
17
     (drop     (mcar x))
18
     (branch   (+ 1 (dom (mcar x))))
19
     (otherwise
20
       (subclass-responsibility x))))
21
 
22
 (defmethod codom ((x <bitc>))
23
   "Gives the length of the bit vector the [\\<BITC\\>] morphism returns"
24
   (typecase-of bitc x
25
     (compose  (codom (mcar x)))
26
     (fork     (* 2 (mcar x)))
27
     (parallel (+ (codom (mcar x)) (codom (mcadr x))))
28
     (swap     (+ (mcar x) (mcadr x)))
29
     (one      1)
30
     (zero     1)
31
     (ident    (mcar x))
32
     (drop     0)
33
     (branch   (codom (mcar x)))
34
     (otherwise
35
       (subclass-responsibility x))))
36
 
37
 
38
 (defmethod gapply ((morphism <bitc>) (object bit-vector))
39
   "My My main documentation can be found on [GAPPLY][generic-function]
40
 
41
 I am the [GAPPLY][generic-function] for [\\<BITC\\>][class], the
42
 OBJECT that I expect is of type NUMBER. [GAPPLY][generic-function]
43
 reduces down to ordinary common lisp expressions rather straight
44
 forwardly
45
 
46
 ```lisp
47
 ;; figure out the number of bits the function takes
48
 GEB-TEST> (dom (to-bitc geb-bool:and))
49
 2 (2 bits, #x2, #o2, #b10)
50
 GEB-TEST> (gapply (to-bitc geb-bool:and) #*11)
51
 #*1
52
 GEB-TEST> (gapply (to-bitc geb-bool:and) #*10)
53
 #*0
54
 GEB-TEST> (gapply (to-bitc geb-bool:and) #*01)
55
 #*0
56
 GEB-TEST> (gapply (to-bitc geb-bool:and) #*00)
57
 #*0
58
 ```"
59
   ;; use a non copying version of subseq some time
60
   (etypecase-of bitc morphism
61
     (compose  (gapply (mcar morphism)
62
                       (gapply (mcadr morphism) object)))
63
     (fork     (concatenate 'bit-vector object object))
64
     (ident    object)
65
     (one      #*1)
66
     (zero     #*0)
67
     (drop     #*)
68
     (swap
69
      (let ((n (mcar morphism)))
70
        (concatenate 'bit-vector (subseq object n) (subseq object 0 n))))
71
     (parallel
72
      (let* ((cx (dom (mcar morphism)))
73
             (inp1 (subseq object 0 cx))
74
             (inp2 (subseq object cx)))
75
        (concatenate 'bit-vector
76
                     (gapply (mcar morphism) inp1)
77
                     (gapply (mcadr morphism) inp2))))
78
     (branch
79
      (let ((without-first-bit (subseq object 1)))
80
        (if (zerop (bit object 0))
81
            (gapply (mcar morphism)  without-first-bit)
82
            (gapply (mcadr morphism) without-first-bit))))))
83
 
84
 (defmethod gapply ((morphism <bitc>) (object list))
85
   "I am a helper gapply function, where the second argument for
86
 [\\<BITC\\>] is a list. See the docs for the BIT-VECTOR version for
87
 the proper one. We do allow sending in a list like so
88
 
89
 ```lisp
90
 ;; figure out the number of bits the function takes
91
 GEB-TEST> (dom (to-bitc geb-bool:and))
92
 2 (2 bits, #x2, #o2, #b10)
93
 GEB-TEST> (gapply (to-bitc geb-bool:and) (list 1 1))
94
 #*1
95
 GEB-TEST> (gapply (to-bitc geb-bool:and) (list 1 0))
96
 #*0
97
 GEB-TEST> (gapply (to-bitc geb-bool:and) (list 0 1))
98
 #*0
99
 GEB-TEST> (gapply (to-bitc geb-bool:and) (list 0 0))
100
 #*0
101
 ```
102
 "
103
   (gapply morphism (coerce object 'bit-vector)))