;;; ========================================================================
;;; Some of the following code are writen by CHEN QING JUN ;
;;; Civil engineering Department, South China University of Technology ;
;;; Purpose: To draw Hyperbolic Tessellation, just for fun ;
;;; The command name :test ;
;;; The platform: Acad2000 and after ;
;;; Version: 1.0 ;
;;; Limitation: Many duplication of arc, need to be overkill ;
;;; Will be improved in the following version ;
;;; Method: From the ideal of http://moniker.name/worldmaking/?p=385 ;
;;; 2012.01.25 ;
;;; ========================================================================
(defun c:test
( / layer mspace p q
) (prompt "\n Please note that the following (p-2)*(q-2) should be larger than 4 !") (setq p
(getint "\n The polygon size p=?:") q
(getint "\n How many Polygon meet at one Vertex. q=?:") layer
(getint "\n How many layer,it is better lower than 5, layer=?:")) (if (< (* (- p
2) (- q
2)) 4) (prompt "\n Sorry, you should change p and q") (makerepeat (DrawCenterPattern p q) layer))
)
)
;;;Draw the Center Pattern
(defun DrawCenterPattern
(p q
/ c centerplst costheta d k p0 p0new p1new r resx s sintheta sx
) ;;This function comes from http://moniker.name/worldmaking/?p=385
(setq r
(/ 1 (sqrt (- (/ (* c c
) (* s s
)) 1)))) (setq d
(/ 1 (sqrt (- 1 (/ (* s s
) (* c c
)))))) ;;resx is the intersection of a line through origin and intersection with the inversion circle
(setq resx
(q:alg:equation:
2 (1+ (* k k
)) (* -2 d
) (- (* d d
) (* r r
)))) (setq sintheta
(sin (/ (* 2 pi
) p
)) costheta
(cos (/ (* 2 pi
) p
))) (setq p0new
(car CenterPlst
));;each new point (+ (* sintheta
(car p0new
))(* costheta
(cadr p0new
))) 0.0)
);;Rotate p0new by angle (2pi/p)
(q:geo:drawPoinCareArc p0new p1new)
(setq CenterPlst
(cons p1new CenterPlst
)) )
(q:geo:drawPoinCareArc p1new p0);;Draw the Last hyperbolic line
CenterPlst
)
;;;Recursive pattern draw, num is the layer definition
(defun makerepeat
(lst num
/ lst1
) (makerepeat res1
(1- num
)) )
)
)
)
;; 2d Mirror Function a b defined the mirror line, c is the point to be mirrored
(defun q:geo:mirrorp
(a b c
) )
;;;;Inverst a Point List about a Hyperbolic line pa-pb Version 0.1
;;; Need to be Improved, An Important function of this code
(defun q:geo:inversePlstto2P
(plst pa pb
/ pav pcenter pnew res x
) (setq pav
(q:geo:invert0 pa
)) (if (< (q:vec:
Length (q:vec:cross
* pa pb
)) 1e
-7
) (setq pnew
(q:geo:mirrorp pa pb x
) (q:geo:drawPoinCareArc
(car res
) (cadr res
)) )
);;;This code deal with the line (pa,pb) pass origin
(setq pcenter
(q:geo:circumcircle3d pa pb pav
)) (setq pnew
(q:geo:invert1 x
(car pcenter
) (cadr pcenter
)) (q:geo:drawPoinCareArc
(car res
) (cadr res
)) )
(q:geo:drawPoinCareArc
(car res
) (last res
));;Draw the last arc )
)
)
;;;A special List deal, Convert '(1 2 3 4 5 ) to
;;;(((1 2)(3 4 5)),((2 3)(4 5 1),((3 4)(5 1 2)),((4 5)(1 2 3)),((5 1)(2 3 4)))
;;;A rotation of the List, each contain (3 4) two element, and the other by order.
(defun q:
list:dealRecur
(lst
/ i len lst3 res
) )
)
)
)
;;;;Draw Hyperbolic line in Poincare disk, Two Condition is consider
(defun q:geo:drawPoinCareArc
(pa pb
/ ang1 ang2 arcobj pav pcenter temp
) (setq pav
(q:geo:invert0 pa
)) (if (< (q:vec:
Length (q:vec:cross
* pa pb
)) 1e
-7
) ;;;Which means the line (pa,pb) go through origin (setq pcenter
(q:geo:circumcircle3d pa pb pav
) (if (> ang1 ang2
) (setq temp ang1 ang1 ang2 ang2 temp
)) (if (> ang2
(+ pi ang1
)) (setq temp ang1 ang1 ang2 ang2 temp
)) )
)
)
;;;Inverse a point to a unit circle
(defun q:geo:invert0
(p
/ d
) (if (< d 1e
-7
) nil (q:vec:
*c p
(/ 1 d d
))) )
;;;Inverse a point to a circle with center and radius r.
(defun q:geo:invert1
(p center r
/ d p1 p2
) (progn (setq p1
(q:vec:
- p center
) p2
(q:vec:
*c p1
(/ (* r r
) d d
))) (q:vec:+ p2 center)
)
)
)
;;;__________________________________________________________________;;
;;;General Function ;;
;;;__________________________________________________________________;;
;;;Get SubList of Lst from N to N+num
)
;;;Solve Quadratic Equations and Get Only the small one. Return nil if no solution
(defun q:alg:equation:
2(a b c
) (if (< (setq temp
(- (* b b
) (* a c
4.
))) 0) nil (/ (- 0 b
(sqrt temp
)) 2. a
)) )
;;entmake Circle
)
;;;;vec plus
;;;;vec substract
;;;;vec plus constant
;;;;vec dot product
;;;;vec cross product
(defun q:vec:cross
*(v1 v2
) )
;;;;Normalize a vec
)
;;;; Vector Length
;;;;determinant library
;;;;cal determinant
;;;;|a1 a2|
;;;;|b1 b2|
(defun q:det:
2(a1 a2 b1 b2
) (- (* a1 b2) (* a2 b1))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;Use Barycentric Coordinates to calculate multiple center
;;;http://mathworld.wolfram.com/BarycentricCoordinates.html
;;;http://en.wikipedia.org/wiki/Barycentric_coordinates_(mathematics)#Converting_to_barycentric_coordinates
(defun q:geo:barycentric
-normalize
(a b c
) )
;;;;transform from barycentric-to-Cartesian coordinate
(defun q:geo:barycentric
-to
-Cartesian
(tlst P1 P2 P3
) (q:vec:
+ (q:vec:
+ (q:vec:
*c P1
(car tlst
)) (q:vec:
*c P2
(cadr tlst
))) (q:vec:
*c P3
(caddr tlst
))) )
;;Find out the circumcircle of three point (three distinct, noncollinear WCS points)
;;;; qjchen@gmail.com
(defun q:geo:circumcircle3d
(p1 p2 p3
/ a b c p temp
) (defun temp
(a b c
) (* a a
(+ (* b b
) (* c c
) (* a
(- a
))))) (setq p
(q:geo:barycentric
-to
-Cartesian
(q:geo:barycentric
-normalize
(temp a b c
) (temp b c a
) (temp c a b
)) P1 P2 P3
)) )
(princ "\n By qjchen@gmail.com, Hyperbolic Tessellation. 1.0, The command is TEST")
