Mon Jul 6 23:50:38 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Pleated Hyperbolic Paraboloid
diff -rN -u old-qt.examples/src/origami/Makefile new-qt.examples/src/origami/Makefile
--- old-qt.examples/src/origami/Makefile 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.examples/src/origami/Makefile 2014-10-30 06:59:48.000000000 +0100
@@ -0,0 +1,7 @@
+tri.lisp : tri.head.lisp tri.input tri.util.lisp
+ cp tri.head.lisp $@
+ echo ')read "tri.input"' | AXIOMsys
+
+.PHONY: clean
+clean:
+ rm -f tri.lisp
diff -rN -u old-qt.examples/src/origami/origami.lisp new-qt.examples/src/origami/origami.lisp
--- old-qt.examples/src/origami/origami.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.examples/src/origami/origami.lisp 2014-10-30 06:59:48.000000000 +0100
@@ -0,0 +1,272 @@
+;;; Pleated Hyperbolic Paraboloid
+;;;
+;;; Construction using the method in:
+;;; (Non)existence of Pleated Folds: How Paper Folds Between Creases
+;;; 6 Existence of Triangulated Hyperbolic Paraboloid
+;;; http://arxiv.org/abs/0906.4747
+;;;
+;;; depends on: :qt.examples tri.lisp :cl-opengl :cl-glu
+
+(in-package :qt.examples)
+
+(defun triangulid-length (n diagonal-part-length)
+ "Length of the extra fold from ring N to the next."
+ (sqrt (+ (expt (* n diagonal-part-length) 2)
+ (expt (* (1+ n) diagonal-part-length) 2))))
+
+(defun length-in-diagonal-plane (distance-to-plane length)
+ "Length in the r z plane."
+ (sqrt (- (expt length 2)
+ (expt distance-to-plane 2))))
+
+(defun next-vertex (z-x r-x z-y diagonal-part-length
+ length-in-diagonal-plane n)
+ (multiple-value-bind (r-1 z-1)
+ (v1 z-x z-y
+ r-x
+ diagonal-part-length
+ length-in-diagonal-plane)
+ (multiple-value-bind (r-2 z-2)
+ (v2 z-x z-y
+ r-x
+ diagonal-part-length
+ length-in-diagonal-plane)
+ ;; alternate valley and mountain fold
+ (if (or (and (> z-1 z-2)
+ (evenp n))
+ (and (< z-1 z-2)
+ (oddp n)))
+ (values z-1 r-1)
+ (values z-2 r-2)))))
+
+(defun make-grid-points (fold-angle n)
+ "Returns the vertex points for FOLD-ANGLE of the center diagonal
+and N rings."
+ ;; Cylindrical coodinates (θ = 0 or θ = π/2)
+ ;; the x and y axes are the diagonals of the square paper.
+ ;; Due to symetry only one fourth need to be calculated.
+ (let (;; θ = 0
+ (z-x (make-array n
+ :element-type 'double-float
+ :initial-element 0d0))
+ (r-x (make-array n
+ :element-type 'double-float
+ :initial-element 0d0))
+ ;; θ = π/2
+ (z-y (make-array n
+ :element-type 'double-float
+ :initial-element 0d0))
+
+ (r-y (make-array n
+ :element-type 'double-float
+ :initial-element 0d0))
+ (diagonal-part-length 1d0))
+ ;; the innermost square
+ (setf (aref r-x 0) diagonal-part-length)
+ (setf (aref z-y 0)
+ (- (* (cos (/ fold-angle 2)) diagonal-part-length))
+ (aref r-y 0)
+ (* (sin (/ fold-angle 2)) diagonal-part-length))
+
+ (dotimes (ring (1- n))
+ (let ((length-in-diagonal-plane
+ (length-in-diagonal-plane (aref r-y ring)
+ (triangulid-length
+ (1+ ring)
+ diagonal-part-length))))
+ (multiple-value-bind
+ (z1 r1)
+ (next-vertex (aref z-x ring) (aref r-x ring)
+ (aref z-y ring) diagonal-part-length
+ length-in-diagonal-plane ring)
+ (setf (aref z-x (1+ ring)) z1)
+ (setf (aref r-x (1+ ring)) r1)))
+ (let ((length-in-diagonal-plane
+ (length-in-diagonal-plane (aref r-x (1+ ring))
+ (* (sqrt 2) (+ 2 ring)))))
+ (multiple-value-bind
+ (z2 r2)
+ (next-vertex (aref z-y ring) (aref r-y ring)
+ (aref z-x (1+ ring)) diagonal-part-length
+ length-in-diagonal-plane ring)
+ (setf (aref z-y (1+ ring)) z2)
+ (setf (aref r-y (1+ ring)) r2))))
+ (values z-x r-x z-y r-y)))
+
+(defclass origami-view (qt:glwidget)
+ ((object :accessor object)
+ (animate)
+ (rings :initform 4 :accessor rings)
+ (rings-changed :reader rings-changed)
+ (fold-angle :initform Pi :accessor fold-angle)
+ (fold-angle-changed :reader fold-angle-changed))
+ (:metaclass cxx:class))
+
+(defmethod initialize-instance :after ((view origami-view) &rest initargs)
+ (declare (ignore initargs))
+ (cxx:set-minimum-size view 200 200)
+ (setf (slot-value view 'rings-changed)
+ (qt:make-slot #'(lambda (rings)
+ (setf (rings view) rings)
+ (make-origami view (fold-angle view)
+ (rings view)))))
+ (setf (slot-value view 'fold-angle-changed)
+ (qt:make-slot #'(lambda (fold-angle)
+ (setf (fold-angle view)
+ (* (/ pi 180) fold-angle))
+ (make-origami view (fold-angle view)
+ (rings view)))))
+ (let ((animate (make-instance 'qt:timer)))
+ (setf (cxx:interval animate) (* 1/25 1000)
+ (slot-value view 'animate) animate)
+ (qt:connect (qt:get-signal animate "timeout()")
+ (qt:get-slot view "update()"))))
+
+(defun inner-square (z-x r-x z-y r-y)
+ "OpenGL vertices for the inner square."
+ (gl:with-primitive :triangle-strip
+ (gl:normal 0d0 (aref z-y 0) (- (aref r-y 0)))
+ (gl:vertex 0d0 (aref r-y 0) (aref z-y 0))
+ (gl:vertex (aref r-x 0) 0d0 (aref z-x 0))
+
+ (gl:vertex (- (aref r-x 0)) 0d0 (aref z-x 0))
+ (gl:normal 0d0 (- (aref z-y 0)) (- (aref r-y 0)))
+ (gl:vertex 0d0 (- (aref r-y 0)) (aref z-y 0))))
+
+(defun triangle-strip (z-x r-x z-y r-y x-direction y-direction)
+ "Generates a OpenGL triangle strip for one quarter not
+including the inner square part."
+ (declare (type (or (eql 1) (eql -1)) x-direction y-direction))
+ (gl:with-primitives :triangle-strip
+ (loop for i from 0 below (1- (length z-x))
+ do
+ (ring-edge-vertices (aref z-x i) (aref r-x i)
+ (aref z-y i) (aref r-y i)
+ x-direction y-direction)
+ (normal (* x-direction (aref r-x i)) 0d0 (aref z-x i)
+ 0d0 (* y-direction (aref r-y i)) (aref z-y i)
+ (* x-direction (aref r-x (1+ i))) 0d0 (aref z-x (1+ i)))
+ finally
+ (ring-edge-vertices (aref z-x i) (aref r-x i)
+ (aref z-y i) (aref r-y i)
+ x-direction y-direction))))
+
+
+(defun ring-edge-vertices (z-x r-x z-y r-y x-direction y-direction)
+ "The two vertices of a fourth of a ring."
+ (let ((r-x (* x-direction r-x))
+ (r-y (* y-direction r-y)))
+ (if (= 0 (* x-direction y-direction ))
+ (progn
+ (gl:vertex 0d0 r-y z-y)
+ (gl:vertex r-x 0d0 z-x))
+ (progn
+ (gl:vertex r-x 0d0 z-x)
+ (gl:vertex 0d0 r-y z-y)))))
+
+(defun normal (mid-x mid-y mid-z
+ x1 y1 z1
+ x2 y2 z2)
+ "Generates a OpenGL normal normal to three points."
+ (let* ((vec1 (vector (- x1 mid-x) (- y1 mid-y) (- z1 mid-z)))
+ (vec2 (vector (- x2 mid-x) (- y2 mid-y) (- z2 mid-z)))
+ (cross-product (vector (- (* (aref vec1 1) (aref vec2 2))
+ (* (aref vec2 1) (aref vec1 2)))
+ (- (* (aref vec2 0) (aref vec1 2))
+ (* (aref vec1 0) (aref vec2 2)))
+ (- (* (aref vec1 0) (aref vec2 1))
+ (* (aref vec2 0) (aref vec1 1))))))
+ (gl:normal (aref cross-product 0)
+ (aref cross-product 1)
+ (aref cross-product 2))))
+
+(defun make-hyperbolic-parabolid (z-x r-x z-y r-y)
+ (gl:material :front-and-back :ambient #(0.6 0.6 0.6 1.0))
+ (gl:material :front-and-back :diffuse #(0.4 0.4 0.4 1.0))
+ (inner-square z-x r-x z-y r-y)
+ (triangle-strip z-x r-x z-y r-y 1 1)
+ (triangle-strip z-x r-x z-y r-y -1 1)
+ (triangle-strip z-x r-x z-y r-y 1 -1)
+ (triangle-strip z-x r-x z-y r-y -1 -1))
+
+(defun make-origami (view fold-angle rings)
+ (handler-case
+ (let ((grid-points
+ (multiple-value-list
+ (make-grid-points fold-angle rings))))
+
+ (gl:with-new-list ((object view) :compile)
+ (gl:scale (/ 1.0 rings) (/ 1.0 rings) (/ 1.0 rings))
+ (apply #'make-hyperbolic-parabolid
+ grid-points)))
+ ((or type-error arithmetic-error) (condition)
+ (warn "Can not fold: ~A." condition)
+ (sb-debug:backtrace 10)
+ (gl:with-new-list ((object view) :compile))))
+ (cxx:update view))
+
+(defmethod cxx:initialize-gl ((view origami-view))
+ (gl:check-error)
+ (gl:clear-color 0 0 0 0)
+ (gl:shade-model :flat)
+ (gl:light :light0 :position '(2 2 1 1))
+ (gl:light :light0 :ambient '(1 1 1 1))
+ (gl:light :light0 :diffuse '(1 1 1 1))
+ (gl:light-model :light-model-two-side 1)
+ (gl:enable :light0 :lighting :normalize :depth-test)
+ ;(gl:enable :line-smooth)
+ (setf (object view) (gl:gen-lists 1))
+ (gl:check-error)
+ (make-origami view 2.5 5)
+ (cxx:start (slot-value view 'animate)))
+
+(defmethod cxx:paint-gl ((view origami-view))
+ (gl:clear :color-buffer :depth-buffer)
+ (gl:load-identity)
+ (gl:translate 0 0 -2)
+ (gl:rotate -60 1 0 0)
+ (gl:rotate (mod (* 4 (/ (get-internal-real-time)
+ internal-time-units-per-second))
+ 360)
+ 0 0 1)
+ (gl:call-list (object view))
+ (gl:check-error))
+
+(defmethod cxx:resize-gl ((view origami-view) width height)
+ (gl:viewport 0 0 width height)
+ (gl:matrix-mode :projection)
+ (gl:load-identity)
+ (glu:perspective 50 (/ width height) 0.5 20)
+ (gl:matrix-mode :modelview)
+ (gl:load-identity)
+ (gl:check-error))
+
+(defclass origami (qt:widget)
+ ((view :initform (make-instance 'origami-view)
+ :reader view))
+ (:metaclass cxx:class))
+
+(defmethod initialize-instance :after ((origami origami) &rest initargs)
+ (declare (ignore initargs))
+ (let ((layout (make-instance 'qt:hbox-layout)))
+ (cxx:add-widget layout (view origami))
+ (let ((fold-angle (make-instance 'qt:slider))
+ (rings (make-instance 'qt:slider)))
+ (cxx:add-widget layout fold-angle)
+ (cxx:add-widget layout rings)
+ (qt:do-delayed-initialize
+ (qt:connect (qt:get-signal fold-angle "valueChanged(int)")
+ (fold-angle-changed (view origami)))
+ (setf (cxx:minimum fold-angle) 0
+ (cxx:value fold-angle) 150
+ (cxx:maximum fold-angle) 360
+ (cxx:tick-position fold-angle) qt:slider.+ticks-left+
+ (cxx:tick-interval fold-angle) 90)
+ (qt:connect (qt:get-signal rings "valueChanged(int)")
+ (rings-changed (view origami)))
+ (setf (cxx:minimum rings) 1
+ (cxx:value rings) 20
+ (cxx:maximum rings) 50
+ (cxx:tick-position rings) qt:slider.+ticks-right+
+ (cxx:tick-interval rings) 10)))
+ (cxx:set-layout origami layout)))
diff -rN -u old-qt.examples/src/origami/tri.head.lisp new-qt.examples/src/origami/tri.head.lisp
--- old-qt.examples/src/origami/tri.head.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.examples/src/origami/tri.head.lisp 2014-10-30 06:59:48.000000000 +0100
@@ -0,0 +1,6 @@
+(in-package :qt.examples)
+
+(declaim (inline ^))
+(defun ^ (base power)
+ (expt base power))
+
diff -rN -u old-qt.examples/src/origami/tri.input new-qt.examples/src/origami/tri.input
--- old-qt.examples/src/origami/tri.input 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.examples/src/origami/tri.input 2014-10-30 06:59:48.000000000 +0100
@@ -0,0 +1,8 @@
+-- echo ')read tst.input' | AXIOMsys >tst.output
+a := radicalSolve([R**2+(Z-Z2)**2 = R2**2, (R-D1)**2 + (Z-Z1)**2 = R1**2], [R,Z])
+
+)lisp (load "tri.util.lisp")
+
+rhsmap(list) == map(rhs, list)
+PRINTEXPRESSIONSDEFUN("tri.lisp", '[V1 V2],
+ '[Z1, Z2, D1, R1, R2], map(simplify,map(rhsmap,a))::InputForm)$Lisp
diff -rN -u old-qt.examples/src/origami/tri.util.lisp new-qt.examples/src/origami/tri.util.lisp
--- old-qt.examples/src/origami/tri.util.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.examples/src/origami/tri.util.lisp 2014-10-30 06:59:48.000000000 +0100
@@ -0,0 +1,19 @@
+(defun expression-defun (name variables expressions)
+ `(defun ,name ,variables
+ (values ,@(rest expressions))))
+
+(defun print-to-file (file expression)
+ (with-open-file (out file :direction :output
+ :if-exists :append :if-does-not-exist :create)
+ (let ((*print-case* :downcase))
+ (print expression out)
+ (terpri out))))
+
+(defun printexpressionsdefun (name function-names variables expressions)
+ (loop
+ for function-name in (first (rest function-names))
+ for expression in (rest (first (rest expressions))) do
+ (print-to-file name (expression-defun function-name
+ (rest variables)
+ expression))))
+