(load "package.lisp")
(load "bezier.lisp")
(load "svg.lisp")
(ql:quickload :alexandria)
(defconstant m 11)
(defconstant n 4)
(defconstant tspace 25)
(defconstant tcenter 5.0)
(defconstant tspread 3.5)
(defconstant tdiffmin 0.25)
(defun choose-edge-hlen (existing)
(let ((new-len (+ tcenter (- (random (* 2.0 tspread)) tspread))))
(if (< (abs (- existing new-len)) tdiffmin)
(choose-edge-hlen existing)
new-len)))
(defun base-len (edge-hlen) (* (tan (* pi (/ 60 180))) edge-hlen))
(defun random-ortho (v)
"randomly pick and return one of the two unit vectors orthogonal to the given unit vector"
(if (= 0 (random 2))
(cons (cdr v) (- (car v)))
(cons (- (cdr v)) (car v))
))
(defun random-signed (v)
(* (random v) (if (= 0 (random 2)) -1 1)))
(defun pick-base (hlen seed)
(let* ((seed-hlen (* 0.5 (norm (vec- (first seed) (second seed)))))
(slop (abs (- seed-hlen hlen)))
(offset (if (< slop 0) 0 (random-signed (float slop))))
(d (normalize (vec- (second seed) (first seed))))
(c (vec* 0.5 (vec+ (second seed) (first seed))))
)
(vec+ c (vec* offset d))
))
(defstruct state polys edges)
(defun add-tri (s p1 p2 p3)
(make-state :polys (cons (list p1 p2 p3 p1) (state-polys s))
:edges (list* (list p1 p2) (list p2 p3) (list p3 p1) (state-edges s))))
(defun new-tri (s)
(if (null s)
(add-tri (make-state)
(cons (/ tcenter 2.0) 0)
(cons (/ tcenter -2.0) 0)
(cons 0 (- (base-len (/ tcenter 2.0)))))
(let* ((seed (alexandria:random-elt (state-edges s)))
(edge-hlen (choose-edge-hlen (* 0.5 (norm (vec- (first seed) (second seed))))))
(center (pick-base edge-hlen seed))
(v (normalize (vec- (second seed) (first seed))))
(p1 (vec- center (vec* edge-hlen v)))
(p2 (vec+ center (vec* edge-hlen v)))
(p3 (vec+ center (vec* (base-len edge-hlen) (random-ortho v))))
)
(add-tri s p1 p2 p3))))
(defun translate-polys (v polys)
(mapcar (lambda (p) (mapcar (lambda (x) (vec+ x v)) p)) polys))
(defun make-tris ()
(reduce
(lambda (s ig) (new-tri s))
(loop for i from 0 to (+ 1 (random 4)) collect i)
:initial-value (base-state)
))
(defun space-fill-z (z) (cons (mod z n) (floor (/ z n))))
(defun make-clusters ()
(cdr (reduce (lambda (state-poly-pair z)
(let* ((old-state (car state-poly-pair))
(old-polys (cdr state-poly-pair))
(new-state (new-tri old-state))
(ij (space-fill-z z))
(Tij (cons (* tspace (1+ (car ij))) (* tspace (1+ (cdr ij)))))
(new-polys (translate-polys Tij (state-polys new-state)))
)
(cons new-state (append new-polys old-polys))))
(loop for z from 0 to (1- (* m n)) collect z)
:initial-value nil)))
(defun tri-x.svg() (x.svg (make-clusters)))