Coverage report: /Users/mohacker/src/yurrriq/land-of-lisp/src/wumpus.lisp

KindCoveredAll%
expression0204 0.0
branch018 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :cl-user)
2
 (defpackage lol.wumpus
3
   (:use :cl :prove))
4
 (in-package :lol.wumpus)
5
 
6
 
7
 ;; TODO: (load "graph-util")
8
 
9
 
10
 (defparameter *congestion-city-nodes* nil)
11
 (defparameter *congestion-city-edges* nil)
12
 (defparameter *visited-nodes* nil)
13
 (defparameter *node-num* 30 )
14
 (defparameter *edge-num* 45)
15
 (defparameter *worm-num* 3)
16
 (defparameter *cop-odds* 15)
17
 
18
 
19
 (defun random-node ()
20
   (1+ (random *node-num*)))
21
 
22
 
23
 (defun edge-pair (a b)
24
   (unless (eql a b)
25
     (list (cons a b) (cons b a))))
26
 
27
 
28
 (defun make-edge-list ()
29
   (apply #'append (loop repeat *edge-num*
30
                         collect (edge-pair (random-node) (random-node)))))
31
 
32
 
33
 (defun direct-edges (node edge-list)
34
   (remove-if-not (lambda (x)
35
                    (eql (car x) node))
36
                  edge-list))
37
 
38
 
39
 (defun get-connected (node edge-list)
40
   (let ((visited nil))
41
     (labels ((traverse (node)
42
                (unless (member node visited)
43
                  (push node visited)
44
                  (mapc (lambda (edge)
45
                          (traverse (cdr edge)))
46
                        (direct-edges node edge-list)))))
47
       (traverse node))
48
     visited))
49
 
50
 
51
 (defun find-islands (nodes edge-list)
52
   (let ((islands nil))
53
     (labels ((find-island (nodes)
54
                (let* ((connected (get-connected (car nodes) edge-list))
55
                       (unconnected (set-difference nodes connected)))
56
                  (push connected islands)
57
                  (when unconnected
58
                    (find-island unconnected)))))
59
       (find-island nodes))
60
     islands))
61
 
62
 
63
 (defun connect-with-bridges (islands)
64
   (when (cdr islands)
65
     (append (edge-pair (caar islands) (caadr islands))
66
             (connect-with-bridges (cdr islands)))))
67
 
68
 
69
 (defun connect-all-islands (nodes edge-list)
70
   (append (connect-with-bridges (find-islands nodes edge-list)) edge-list))
71
 
72
 
73
 (defun make-city-edges ()
74
   (let* ((nodes (loop for i from 1 to *node-num*
75
                       collect i))
76
          (edge-list (connect-all-islands nodes (make-edge-list)))
77
          (cops (remove-if-not (lambda (x)
78
                                 (zerop (random *cop-odds*)))
79
                               edge-list)))
80
     (add-cops (edges-to-alist edge-list) cops)))
81
 
82
 
83
 (defun edges-to-alist (edge-list)
84
   (mapcar (lambda (node1)
85
             (cons node1
86
                   (mapcar (lambda (edge)
87
                             (list (cdr edge)))
88
                           (remove-duplicates (direct-edges node1 edge-list)
89
                                              :test #'equal))))
90
           (remove-duplicates (mapcar #'car edge-list))))
91
 
92
 
93
 (defun add-cops (edge-alist edges-with-cops)
94
   (mapcar (lambda (x)
95
             (let ((node1 (car x))
96
                   (node1-edges (cdr x)))
97
               (cons node1
98
                     (mapcar (lambda (edge)
99
                               (let ((node2 (car edge)))
100
                                 (if (intersection (edge-pair node1 node2)
101
                                                   edges-with-cops
102
                                                   :test #'equal)
103
                                     (list node2 'cops)
104
                                     edge)))
105
                             node1-edges))))
106
           edge-alist))
107
 
108
 
109
 (defun neighbors (node edge-alist)
110
   (mapcar #'car (cdr (assoc node edge-alist))))
111
 
112
 
113
 (defun within-one (a b edge-alist)
114
   (member b (neighbors a edge-alist)))
115
 
116
 
117
 (defun within-two (a b edge-alist)
118
   (or (within-one a b edge-alist)
119
       (some (lambda (x)
120
               (within-one x b edge-alist))
121
             (neighbors a edge-alist))))
122
 
123
 
124
 (defun make-city-nodes (edge-alist)
125
   (let ((wumpus (random-node))
126
         (glow-worms (loop for i below *worm-num*
127
                           collect (random-node))))
128
     (loop for n from 1 to *node-num*
129
           collect (append (list n)
130
                           (cond ((eql n wumpus) '(wumpus))
131
                                 ((within-two n wumpus edge-alist) '(blood!)))
132
                           (cond ((member n glow-worms)
133
                                  '(glow-worm))
134
                                 ((some (lambda (worm)
135
                                          (within-one n worm edge-alist))
136
                                        glow-worms)
137
                                    '(lights!)))
138
                           (when (some #'cdr (cdr (assoc n edge-alist)))
139
                             '(sirens!))))))
140
 
141