Code I wrote around 2009 for rendering Lavaurs chords (an abstract Mandelbrot set). Blame my old self for my poor Lisp

Lavaurs.lsp

;;  Copyright 2009 Rubén Berenguel

;;  ruben /at/ maia /dot/ ub /dot/ es

;;  This program is free software: you can redistribute it and/or
;;  modify it under the terms of the GNU General Public License as
;;  published by the Free Software Foundation, either version 3 of the
;;  License, or (at your option) any later version.

;;  This program is distributed in the hope that it will be useful,
;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;  General Public License for more details.

;;  You should have received a copy of the GNU General Public License
;;  along with this program. If not, see
;;  <http://www.gnu.org/licenses/>.

;;  This program is called (LavaursChords N), where N is a period
;;  depth, ranging from 2 to any positive number. Due to optimization
;;  issues, do not go deeper than 12 or 13, as it would take a really
;;  long time.


(defvar PERIODS
  "A global variable, needed to avoid messiness in the code.")

(setq PERIODS '())

(defun LavaursChords (depth)
  "To generate the image, call (LavaursChords N) Do not go further
  than 10, 11 as it would take quite a while to draw, this program is
  not optimized."
  (CircleTrace (GenerateListOfCircles depth)))

(defun GenerateListOfCircles (Depth)
  "This generates the final list of chords. "
  (Arcs Depth 1 100 '(((0 0) 0))))


(defun Arc (R alpha balpha)
  "Find the ortogonal circle to the main circle, given the angles in
  it. R: radius of the main circle alpha, balpha angles of the first
  and second point (a, b) first point (ba, bb) second point"
  (let* (
	 (gamma (+ alpha (/ (- balpha alpha) 2)))
	 (ca (cos alpha))
	 (cg (cos gamma))
	 (sa (sin alpha))
	 (sg (sin gamma))
	 (denom (+ (* ca cg) (* sa sg)))
	 (a (* R ca))
	 (b (* R sa))
	 (x (/ (* R cg) denom))
	 (y (/ (* R sg) denom))
	 (xma (- x a))
	 (ymb (- y b))
	 )
    (list (list x y)	
	  (sqrt (+ (* xma xma) (* ymb ymb))))))
	
(defun DrawArc (alpha balpha R)
  "Generate the postscript arcs"
  (format t "newpath ~A ~A moveto 300 300 ~A ~A ~A arct" 
	  (+ 300 (* 100 (cos balpha))) 
	  (+ 300 (* 100 (sin balpha)))
	  (+ 300 (* 100 (cos alpha))) 
	  (+ 300 (* 100 (sin alpha)))
	  R))
       
(defun PeriodK (k)
  "Returns the list of period k (and below), rational points"
  (PeriodKAux k (FullList k)))

(defun PeriodKAux (k Previous)
  "Auxiliary function to remove duplicates in PeriodK"
  (if (= k 0)
      Previous
      (PeriodKAux (- k 1) (RemDouble Previous (FullList (- k 1))))))


(defun FullList (k)
  "Returns a list of angles of period K. This does the dirty work for
  PeriodK, creating all points. Then PeriodKAux trims the resulting
  list off duplicates"
  (let ((Periods '()))
    (do ((n 1 (+ n 1))) ((>= n (- (expt 2 k) 1)) Periods)
      
	  (setq Periods (append Periods (list (/ n (- (expt 2 k) 1)))))

	  )))
  
(defun RemDouble (list1 list2)
  "This function removes duplicates in the way I wanted. List1 is the
  longer one."
  (if (>(length list2) 0)
      (RemDouble (remove (car List2) List1) (cdr List2))
      list1
      ))



(defun SomeArc (R List1 List2 PreviousArcs )
  "Decide whether we can draw a new arc or not. Recurse"
  (if (and List1 List2)
      (if (CanDraw (car List1) (car List2) R PreviousArcs)
	  (let ((ArcXY (list (Arc R (* 2
			    pi (car List1)) (* 2 pi (car List2))) 
			     )))
	    (delete (car List1) List1)
	    (delete (car List2) List1)
	    (delete (car List2) List2)
	    ArcXY)
	    (SomeArc R List1 (cdr List2) PreviousArcs))
      NIL
      ))

(defun GetArcs (R List1 List2 PreviousArcs)
  "List1 contains (PM PM+1... PN) List2 contains the second element,
  i.e. we try to get an arc from (car List1) to (car List2) if we can,
  recurse with the trimmed lists List1' List2' if we cannot, recurse
  with the trimmed lists List1 List2'"
  (if List2
      (append (SomeArc R List1 List2 PreviousArcs) 
	      (GetArcs R (cdr List1) (cdr List2) PreviousArcs ))))

      

(defun Arcs (MaxPeriod CurrentPeriod R Previous)
  "R is the radius of the main circle MaxPeriod is the maximum period
  CurrentPeriod is the current period Previous contains the previous
  arcs as center, radius"
  (if (< CurrentPeriod MaxPeriod)
      (progn 
	(setq PERIODS (PeriodK CurrentPeriod))
      (Arcs MaxPeriod (+ 1 CurrentPeriod) R 
	    (append Previous 
		    (GetArcs R  PERIODS (cdr PERIODS) Previous))))
      
  Previous))

(defun CanDraw (X Y R Previous)
  "The most important function. Decide whether we can draw an arc (it
   not intersects previous arcs) or not"
  (if Y
      (let* (
	     (X2 (* 2 pi X))
	     (Y2 (* 2 pi Y))
	     (ArcXY (Arc R X2 Y2)))
	(andF (mapcar #'(lambda (A) 
			  (and (or (> (dist (car A) (car ArcXY)) (+ (cadr
							    A) (cadr
							    ArcXY)))
			  (> (abs (- (cadr A) (cadr ArcXY))) 
			     (dist (car A) (car ArcXY)))
			  )(> (cadr ArcXY) 0.00000001)
			  
			  ) ) Previous))) ))

(defun andF (List1)
  "A recursive 'and' for a list of T, NILs"
  (if (not List1)
      t
      (and (car List1) (andF (cdr List1)))))

 (defun dist (L1 L2)
   "Standard euclidean distance for two lists of 3 elements"
   (let ((M1 (- (car L1) (car L2)))
	 (M2 (- (cadr L1) (cadr L2))))
   (sqrt (+ (* M1 M1) (* M2 M2)))))


(defun Remaining (element elist)
  (if (not elist) nil 
      (if (= element (car elist)) (cdr elist)
	  (Remaining element (cdr elist)))))

(defun CircleTraceColor (ListOfCircles)
  "A random color assigner for the list of circles to be drawn. Just
   for the artistic effect."
  (with-open-file (PostScriptFile "LavaursColor.eps" :direction :output
		       :if-exists :supersede) 
    
    (format PostScriptFile " 
%!PS-Adobe-3.0 EPSF-3.0 
%%BoundingBox: 198 198 402 402 
gsave newpath

newpath
    198 198 moveto
    198 402 lineto
    402 402 lineto
    402 198 lineto
    198 198 lineto
closepath
0.08235 0.0352 0.17842 setrgbcolor
fill

 300.00000000 300.00000000 100.00000000 0
360 arc gsave 0 setlinewidth stroke grestore clip~%")
    (format PostScriptFile "newpath ~%")
    (dolist (Circle ListOfCircles)
      (format PostScriptFile " ~,8F ~,8F ~,8F 0 360 arc  0 setlinewidth
  ~A ~A ~A setrgbcolor stroke ~%"
	      (+ 300 (caar Circle))
	      (+ 300 (cadar Circle))
	      (cadr Circle)
	      (random 1.0)
	      (random 1.0)
	      (random 1.0)))
    (format PostScriptfile "~% showpage")))
  
(defun CircleTrace (ListOfCircles)
  "A postscript tracer for the list of circles"
  (with-open-file (PostScriptFile "Lavaurs.eps" :direction :output 
				  :if-exists :supersede) 
    (format PostScriptFile " 
%!PS-Adobe-3.0 EPSF-3.0 
%%BoundingBox: 198 198 402 402 

 300.00000000 300.00000000 100.00000000 0
360 arc gsave 0 setlinewidth stroke grestore clip~%")
    (format PostScriptFile "newpath ~%")
    (dolist (Circle ListOfCircles)
      (format PostScriptFile " ~,8F ~,8F ~,8F 0 360 arc  0 setlinewidth
   stroke ~%"
	      (+ 300 (caar Circle))
	      (+ 300 (cadar Circle))
	      (cadr Circle)))
    (format PostScriptfile "~% showpage")))