#+TITLE: (sphere) csg lisp org
#+AUTHOR: screwtape
#+EMAIL: screwtape@sdf.org
* org tables to bubbly stereolithographs with gmsh geometry
If you need help getting it working give me a shout!
** Requirements are
emacs, orgmode, slime,
and having gmsh installed.
I'm just printing a gmsh geometry. gmsh does the work (probably using oce) ;
looked at with gmsh's fltk gui.
Pro tip: Turn on surfaces in gmsh's tools>Options geometry and mesh checkboxes.
** org-doc usage
1. Find or make a table like the ones in ** tables
2. Give that table to create's :var table=diamond
   (with your table's #+name: instead of diamond)
3. Run (C-c C-c yes <ret>) with the cursor at the create lisp src block in
4. Run the mesh-and-show shell src block
Tangling to lisp/shell files also works fine. (C-c C-v t)
** Table format:
- (start-number . end-number) defines radius-overlapping bubbles in an obvious range.
- end-number fills (1 . end-number)
- Empty cells should be 0 (which would try to fill 1 to 0,  and hence be eaten by nconc)
- Non-numeric cells are passed to lisp as strings, which then READs them. Caveat emptor.
- Just look at the tables and some pngs. (1pngs/superman.png and 1pngs/diamond.png)
** tables
*** superman s
#+name: superman
| 0 | 1 | 0 |
| 1 | 0 | 1 |
| 1 | 0 | 1 |
| 1 | 0 | 0 |
| 0 | 1 | 0 |
| 0 | 0 | 1 |
| 1 | 0 | 1 |
| 1 | 0 | 1 |
| 0 | 1 | 0 |
*** diamond
**** lisp
#+begin_src lisp :results value
  (loop for x from 1 to 5 collecting
       (loop for y from 1 to 5 collecting
	    (cond
	      ((= x y 3) (cons 1 5))
	      ((and (< x 5) (> x 1)
		    (< y 5) (> y 1))
	       (cons 2 4))
	      (t (cons 3 3)))))
#+end_src

#+RESULTS:
**** table
#+name: diamond
| (3 . 3) | (3 . 3) | (3 . 3) | (3 . 3) | (3 . 3) |
| (3 . 3) | (2 . 4) | (2 . 4) | (2 . 4) | (3 . 3) |
| (3 . 3) | (2 . 4) | (1 . 5) | (2 . 4) | (3 . 3) |
| (3 . 3) | (2 . 4) | (2 . 4) | (2 . 4) | (3 . 3) |
| (3 . 3) | (3 . 3) | (3 . 3) | (3 . 3) | (3 . 3) |

** create geometry
#+name: create
#+begin_src lisp :noweb yes :var table=diamond :results none
<<table2mesh>>
#+end_src

** Mesh and show with gmsh
#+name: mesh-and-show
#+begin_src shell :results none
  gmsh -o test.stl fromtable.geo -3
  gmsh test.stl
#+end_src

** Base
*** Tangled
#+name: table2mesh
#+begin_src lisp :results output :noweb yes :var table=table :eval never :results none
  <<readornum>>
  <<mesh>>

  (flet ((mesh ()
    (let* ((r 5) (lc 2) (table (read-table-strings))
	   (spheres
	    (loop for row in (read-table-strings) for y from 0 by r nconcing
		 (loop for col in row for x from 0 by r nconcing
		      (loop for height from (if (consp col) (car col) 1)
			 to (if (consp col) (cdr col) col)
			 for z from (* r height) by r
			 collecting (make-instance 'sphere :x x :y y :z z :r r :lc lc))))))
      (when spheres
	(geo-beginning (car spheres))
	(mapc 'fill-forms spheres)
	(with-open-file (*standard-output* #p"fromtable.geo" :direction :output
					   :if-exists :supersede
					   :if-does-not-exist :create)
	  (loop for sphere in spheres do
	       (mapc 'eval (forms sphere))))))))
    (mesh))


#+end_src
*** READ strings leave numbers
#+name: readornum
#+begin_src lisp :noweb yes :results value :eval never
  (defun read-table-strings (&optional (table table))
    (loop for row in table collecting
	 (loop for col in row collecting
	      (if (stringp col) (with-input-from-string (s col) (read s))
		  col))))
#+end_src
*** mesh package / sphere template
#+name: mesh
#+begin_src lisp :eval never
  (defpackage mesh (:use cl) (:export sphere geo-beginning fill-forms))
  (in-package mesh)

  (defclass 3d ()
    ((points :initform nil :accessor points)
     (lc :initarg :lc :reader lc)
     (complexes :initform nil :accessor complexes)
     (phys :initform nil :accessor phys)
     (surface :accessor surface)
     (volume :accessor volume)
     (next-point :allocation :class)
     (next-phy :allocation :class)
     (next-complex :allocation :class))
    (:default-initargs :lc 5))

  (defmethod new-pnt ((obj 3d)) "
  (new-pnt 3D)
  Adds a class-scope new point.
  "
    (let ((idx (incf (slot-value obj 'next-point))))
      (if (null (points obj))
	  (setf (points obj) (list idx))
	(nconc (points obj) (list idx)))
      (values idx)))

  (defmethod pof ((obj 3d) n) "
  (pof 3d x)
  Gets the locally scoped (1- x) indexed point
  "
    (nth (1- n) (points obj)))


  (defmethod cof ((obj 3d) n) "
  (cof 3d x)
  Gets the locally scoped (1- x) indexed complex
  "
    (nth (1- n) (complexes obj)))

  (defmethod new-phy ((obj 3d)) "
  (new-phy 3d)
  Adds a class-scope physical object
  "
    (let ((idx (incf (slot-value obj 'next-phy))))
      (if (null (phys obj))
	  (setf (phys obj) (list idx))
	(nconc (phys obj) (list idx)))
      (values idx)))

  (defmethod new-cpx ((obj 3d)) "
  (new-cpx 3d)
  Adds a class-scope complex object
  "
    (let ((idx (incf (slot-value obj 'next-complex))))
      (if (null (complexes obj))
	  (setf (complexes obj) (list idx))
	(nconc (complexes obj) (list idx)))
      (values idx)))

  (defmethod shared-initialize :after ((obj 3d) names &rest args)
    (declare (ignore names args))
    (unless (slot-boundp obj 'next-point)
     (setf (slot-value obj 'next-point) 0
	   (slot-value obj 'next-complex) 0 
	   (slot-value obj 'next-phy) 0)))

  (defclass sphere (3d)
    ((x :initarg :x :accessor x)
     (y :initarg :y :accessor y)
     (z :initarg :z :accessor z)
     (r :initarg :r :accessor r)
     (sphere-forms :type list :initform (list) :accessor forms))
    (:documentation "
  (make-instance mesh:sphere :x 3 :y 4 :z 5 :r 10 :lc 3)
  Instantiates an object for the printing of a gmsh geometry of 
  said sphere equivalent to gmsh's unit sphere
  (but with class scope indices)
  "))

  (defun blank () '(format t "~%"))

  (defmethod add-point ((obj 3d) x y z)
   (let ((p (new-pnt obj)))
   `(format t "Point(~d) = {~d,~d,~d,lc};~%" ,p ,x ,y ,z)))

  (defmethod add-circle ((obj 3d) a b c &aux (p (pof obj a)) (q (pof obj b)) (r (pof obj c)))
   (let ((s (new-cpx obj)))
    `(format t "Circle(~d) = {~d,~d,~d};~%" ,s ,p ,q ,r)))

  (defun sgn (n) (if (plusp n) 1 -1))

  (defmethod add-curvel ((obj 3d) a b c &aux 
			  (p (* (sgn a) (cof obj (abs a))))
			  (q (* (sgn b) (cof obj (abs b)))) 
			  (r (* (sgn c) (cof obj (abs c)))))
   (let ((s (new-cpx obj)))
    `(format t "Curve Loop(~d) = {~d,~d,~d};~%" ,s ,p ,q ,r)))

  (defmethod add-surface ((obj 3d) x)
   (let ((s (new-cpx obj)))
    `(format t "Surface(~d) = {~d};~%" ,s ,(cof obj x))))

  (defmethod add-volume ((obj 3d) x)
   (let ((s (new-cpx obj)))
    `(format t "Volume(~d) = {~d};~%" ,s ,(cof obj x))))

  (defmethod add-surfl ((obj 3d) &rest args)
   (let ((s (new-cpx obj)) (new-args (mapcar (lambda (x) (cof obj x)) args)))
    `(format t "Surface Loop(~d) = {~@{~d~^,~}};~%" ,s ,@new-args)))

  (defmethod phy-surf ((obj 3d) &rest args)
   (let ((s (new-phy obj)) (new-args (mapcar (lambda (x) (cof obj x)) args)))
    `(format t "Physical Surface(~d) = {~@{~d~^,~}};~%" ,s ,@new-args)))

  (defmethod phy-vol ((obj 3d) vol)
   (let ((s (new-phy obj)))
    `(format t "Physical Volume(~d) = {~d};~%" ,s ,(cof obj vol))))

  (defmethod geo-beginning ((obj sphere) &aux (mesh-algo 6) (lc (lc obj)))
    (setf (forms obj)
	  (list `(format t "~a = ~d;~%" "Mesh.Algorithm" ,mesh-algo)
		(blank)
		`(format t "lc = ~d;~%" ,lc))))

  (defmethod fill-forms ((obj sphere)
			 &aux (x (x obj)) (y (y obj)) (z (z obj))
			 (r (r obj)) (lc (lc obj))) "
  (fill-forms sphere)
  Prints the Gmsh geometry of a unit sphere at (x sphere) .. 
  of radius/lc (r sphere) (lc sphere)
  Exactly equivalent to the the unit sphere from gmsh.
  The point / extrusion / physical counters are class scope
  so subsequent mesh::3d instances can be printed in the same
  geometry. 'complexes' is an erroneous name.
  "
   (setf (forms obj)
    (nconc (forms obj) 
     (list (add-point obj x y z)
      (add-point obj (+ x r) y z)
      (add-point obj x (+ y r) z)
      (add-circle obj 2 1 3)
      (add-point obj (- x r) y z)
      (add-point obj x (- y r) z)
      (add-circle obj 3 1 4) ; 10
      (add-circle obj 4 1 5)
      (add-circle obj 5 1 2)
      (add-point obj x y (- z r))
      (add-point obj x y (+ z r)) ; 14
      (add-circle obj 3 1 6)
      (add-circle obj 6 1 5)
      (add-circle obj 5 1 7)
      (add-circle obj 7 1 3)
      (add-circle obj 2 1 7)
      (add-circle obj 7 1 4)
      (add-circle obj 4 1 6)
      (add-circle obj 6 1 2) ; 22
      (add-curvel obj 2 8 -10)
      (add-surface obj 13)
      (add-curvel obj 10 3 7)
      (add-surface obj 15)
      (add-curvel obj -8 -9 1)
      (add-surface obj 17) ; 28
      (add-curvel obj -11 -2 5)
      (add-surface obj 19)
      (add-curvel obj -5 -12 -1)
      (add-surface obj 21)
      (add-curvel obj -3 11 6)
      (add-surface obj 23)
      (add-curvel obj -7 4 9)
      (add-surface obj 25)
      (add-curvel obj -4 12 -6)
      (add-surface obj 27) ; 38
      (add-surfl obj 28 26 16 14 20 24 22 18)
      (add-volume obj 29)
      (blank)
      (phy-surf obj 28 26 16 14 20 24 22 18)
      (phy-vol obj 30)
      (blank)))))

#+end_src