Coverage report: /home/runner/work/geb/geb/test/geb.lisp

KindCoveredAll%
expression170312 54.5
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb-test)
2
 
3
 (define-test geb :parent geb-test-suite)
4
 
5
 (def prod16
6
   (let* ((prod4 (prod (alias bool (prod so0 so1)) (prod so0 so1)))
7
          (prod8 (prod prod4 prod4)))
8
     (prod prod8 prod8)))
9
 
10
 (def coprod16
11
   (let* ((coprod4 (coprod (alias bool (coprod so0 so1)) (coprod so0 so1)))
12
          (coprod8 (coprod coprod4 coprod4)))
13
     (coprod coprod8 coprod8)))
14
 
15
 
16
 (def mixprod16
17
   (let* ((coprod4 (coprod (alias bool (coprod so0 so1)) (coprod so0 so1)))
18
          (prod8 (prod coprod4 coprod4)))
19
     (coprod prod8 prod8)))
20
 
21
 (def prod32 (prod prod16 prod16))
22
 
23
 (def coprod32 (coprod coprod16 coprod16))
24
 
25
 (def mixprod32 (coprod mixprod16 mixprod16))
26
 
27
 (def test-value
28
   (cleave (<-left so1 so1)
29
           (commutes so1 so1)
30
           (<-left so1 so1)
31
           (<-left so1 so1)
32
           (<-left so1 so1)
33
           (<-left so1 so1)
34
           (<-left so1 so1)
35
           (<-left so1 so1)
36
           (<-left so1 so1)
37
           (<-left so1 so1)
38
           (<-left so1 so1)
39
           (<-left so1 so1)
40
           (<-left so1 so1)
41
           (<-left so1 so1)
42
           (<-left so1 so1)
43
           (<-left so1 so1)
44
           (<-left so1 so1)
45
           (<-left so1 so1)
46
           (<-left so1 so1)
47
           (commutes so1 so1)))
48
 
49
 (def test-value-expansion
50
   '((<-LEFT S-1 S-1) ((<-RIGHT S-1 S-1) (<-LEFT S-1 S-1)) (<-LEFT S-1 S-1)
51
     (<-LEFT S-1 S-1) (<-LEFT S-1 S-1) (<-LEFT S-1 S-1) (<-LEFT S-1 S-1)
52
     (<-LEFT S-1 S-1) (<-LEFT S-1 S-1) (<-LEFT S-1 S-1) (<-LEFT S-1 S-1)
53
     (<-LEFT S-1 S-1) (<-LEFT S-1 S-1) (<-LEFT S-1 S-1) (<-LEFT S-1 S-1)
54
     (<-LEFT S-1 S-1) (<-LEFT S-1 S-1) (<-LEFT S-1 S-1) (<-LEFT S-1 S-1)
55
     (<-RIGHT S-1 S-1) (<-LEFT S-1 S-1)))
56
 
57
 (define-test printer-works-as-expected
58
   :parent geb
59
   (is equalp (read-from-string (format nil "~A" test-value)) test-value-expansion)
60
   (is equalp (read-from-string (format nil "~A" prod16))
61
       '(× (× (× BOOL S-0 S-1) BOOL S-0 S-1) (× BOOL S-0 S-1) BOOL S-0 S-1)))
62
 
63
 (define-test dom-and-codom
64
   :parent geb
65
   (is obj-equalp so1 (dom (pair (->left so1 so1)
66
                                 (->left so1 so1)))
67
       "Checking the dom of pair")
68
   (is obj-equalp
69
       (prod bool
70
             bool)
71
       (codom (pair (->left geb-bool:false-obj geb-bool:true-obj)
72
                    (->left geb-bool:false-obj geb-bool:true-obj)))
73
       "Checking the codom of pair")
74
   (is obj-equalp
75
       (dom (<-left so1 bool))
76
       (prod so1 bool)
77
       "checking dom of projection")
78
   (is obj-equalp
79
       (dom (distribute bool so1 so1))
80
       (prod bool (coprod so1 so1))
81
       "checking dom of distribution")
82
   (is obj-equalp
83
       (codom (distribute bool so1 so1))
84
       (coprod (prod bool so1)
85
               (prod bool so1))
86
       "checking codom of distribution"))
87
 
88
 
89
 (define-test curry
90
   :parent geb
91
   (of-type substmorph (curry (<-left bool bool)))
92
   ;; may be typing this a bit too strictly
93
   (of-type comp (curry (<-left bool so1)))
94
   (is obj-equalp (dom (geb:curry bool:and)) bool))
95
 
96
 
97
 (define-test geb-trans :parent geb)
98
 
99
 (def test-morph-2 (<-left so1 bool))
100
 
101
 (def test-poly-2 (to-poly test-morph-2))
102
 
103
 (def test-bitc-2 (to-bitc test-morph-2))
104
 
105
 (def test-circuit-2 (to-circuit test-morph-2 :tc_2))
106
 
107
 (define-test vampir-test-2
108
   :parent geb-trans
109
   (of-type list test-circuit-2))
110
 
111
 
112
 (define-test geb-interpreter :parent geb)
113
 
114
 ;; PLEASE FUZZ THIS!
115
 (define-test interpret-bool :parent geb-interpreter
116
   (is obj-equalp
117
       (gapply bool:and (list (left so1) (left so1)))
118
       (left so1))
119
 
120
   (is obj-equalp
121
       (gapply bool:and (list (left so1) (right so1)))
122
       (left so1))
123
 
124
   (is obj-equalp
125
       (gapply bool:and (list (right so1) (right so1)))
126
       (right so1))
127
 
128
   (is obj-equalp (gapply bool:not (left so1)) (right so1))
129
 
130
   (is obj-equalp (gapply bool:not (right so1)) (left so1)))
131
 
132
 (define-test geb-de-concat
133
   :parent geb-interpreter
134
   (is obj-equalp (list 1 0) (gapply (geb.extension.spec:nat-decompose 3) 4))
135
   (is obj-equalp 4 (gapply (geb.extension.spec:nat-concat 1 2) (list 1 0)))
136
   (is obj-equalp 4 (gapply (comp (geb.extension.spec:nat-concat 1 2)
137
                                  (geb.extension.spec:nat-decompose 3))
138
                            4))
139
   (is obj-equalp (list 1 0) (gapply (comp (geb.extension.spec:nat-decompose 3)
140
                                           (geb.extension.spec:nat-concat 1 2))
141
                                     (list 1 0))))
142
 ����