#+TITLE: (sphere) csg lisp org
#+AUTHOR: screwtape
#+EMAIL: [email protected]
* 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

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.