Coverage report: /home/ellis/comp/core/lib/math/sfc.lisp

KindCoveredAll%
expression0196 0.0
branch016 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; sfc.lisp --- Space Filling Curves
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :math/sfc)
7
 
8
 ;; recursive
9
 (defun hilbert-list (n)
10
   (unless (zerop n)
11
     (let (points)
12
       (labels ((recur (x y lg i1 i2)
13
                  (if (= lg 1)
14
                      (push (cons x y) points)
15
                      (let ((lg (floor lg 2)))
16
                        (recur (+ x (* i1 lg))       (+ y (* i1 lg))       lg i1       (- 1 i2))
17
                        (recur (+ x (* i2 lg))       (+ y (* (- 1 i2) lg)) lg i1       i2)
18
                        (recur (+ x (* (- 1 i1) lg)) (+ y (* (- 1 i1) lg)) lg i1       i2)
19
                        (recur (+ x (* (- 1 i2) lg)) (+ y (* i2 lg))       lg (- 1 i1) i2)))))
20
         (recur 0 0 (expt n 2) 0 0))
21
       (nreverse points))))
22
 
23
 ;; REVIEW 2025-05-10: something interesting is happening here on odd generations - kinda interesting
24
 (defun hilbert-curve (&optional (n 8))
25
   "Draw one of Hilbert's continuous fractal space-filling curves."
26
   (let* ((points (hilbert-list n))
27
          (dim (expt n 2))
28
         (grid (make-array (list dim dim))))
29
     (let ((start (calculate-box-graphic (first points) (second points) (third points) t)))
30
       (setf (aref grid 0 0) start
31
             (aref grid (1- dim) 0) start))
32
     (loop for (from to next) on points
33
           while next
34
           do (setf (aref grid (car to) (cdr to))
35
                    (calculate-box-graphic from to next)))
36
     (loop for y from 0 to (1- dim)
37
           do (loop for x from 0 to (1- dim)
38
                    do (princ (aref grid x y)))
39
              (fresh-line))))
40
 
41
 (defun calculate-box-graphic (from to next &optional start)
42
   (flet ((direction (from to)
43
            (flet ((x (loc) (car loc))
44
                   (y (loc) (cdr loc)))
45
              (cond
46
                ((< (x from) (x to)) :left)
47
                ((> (x from) (x to)) :right)
48
                ((< (y from) (y to)) :up)
49
                ((> (y from) (y to)) :down)))))
50
     (let ((in (direction from to))
51
           (out (direction next to)))
52
       (if start
53
         (ecase in
54
           (:up #\BOX_DRAWINGS_LIGHT_VERTICAL)
55
           (:left #\BOX_DRAWINGS_LIGHT_HORIZONTAL))
56
         (second (assoc-if (lambda (el)
57
                             (or (and (eq (first el) in)
58
                                      (eq (second el) out))
59
                                 (and (eq (first el) out)
60
                                      (eq (second el) in))))
61
                           '(((:up    :right) #\BOX_DRAWINGS_LIGHT_UP_AND_RIGHT)
62
                             ((:up    :left)  #\BOX_DRAWINGS_LIGHT_UP_AND_LEFT )
63
                             ((:down  :right) #\BOX_DRAWINGS_LIGHT_DOWN_AND_RIGHT)
64
                             ((:down  :left)  #\BOX_DRAWINGS_LIGHT_DOWN_AND_LEFT)
65
                             ((:left  :right) #\BOX_DRAWINGS_LIGHT_HORIZONTAL)
66
                             ((:up    :down)  #\BOX_DRAWINGS_LIGHT_VERTICAL))))))))