factor/contrib/x11/examples/lindenmayer/lindenmayer.factor

USING: kernel alien namespaces arrays vectors math opengl math-contrib
lists parser sequences hashtables strings ;

IN: lindenmayer 

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: make-matrix >r { } make r> swap group ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: RU ( angle -- RU ) deg>rad
[ dup cos ,	dup sin ,	0 ,
  dup sin neg ,	dup cos ,	0 ,
  0 ,		0 ,		1 , ] 3 make-matrix nip ;

: RL ( angle -- RL ) deg>rad
[ dup cos ,	0 ,		dup sin neg ,
  0 ,		1 ,		0 ,
  dup sin ,	0 ,		dup cos , ] 3 make-matrix nip ;

: RH ( angle -- RH ) deg>rad
[ 1 ,		0 ,		0 ,
  0 ,		dup cos ,	dup sin neg ,
  0 ,		dup sin ,	dup cos , ] 3 make-matrix nip ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SYMBOL: position
SYMBOL: orientation

: rotate-U ( angle -- ) RU orientation get swap m. orientation set-global ;
: rotate-L ( angle -- ) RL orientation get swap m. orientation set-global ;
: rotate-H ( angle -- ) RH orientation get swap m. orientation set-global ;

: step ( length -- )
>r position get orientation get 0 0 r> 3array m.v v+ position set-global ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: record-vertex ( -- ) position get first3 glVertex3f ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: rotate-z     rotate-U ;
: rotate-y neg rotate-L ;
: rotate-x neg rotate-H ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: reset ( -- )
{ 0 0 0 } position set-global 3 identity-matrix orientation set-global ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

DEFER: polygon-vertex

: draw-forward ( length -- )
GL_LINES glBegin record-vertex step record-vertex glEnd ;

: move-forward ( length -- ) step polygon-vertex ;

: sneak-forward ( length -- ) step ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

! (v0 - v1) x (v1 - v2)

: polygon-normal ( { v0 v1 v2 } -- normal )
0 over nth over 1 swap nth v- swap
1 over nth swap 2 swap nth v- cross ;

: polygon ( vertices -- )
GL_POLYGON glBegin dup polygon-normal first3 glNormal3f
[ first3 glVertex3f ] each glEnd ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SYMBOL: vertices

V{ } vertices set-global

: start-polygon ( -- ) 0 <vector> vertices set-global ;

: finish-polygon ( -- ) vertices get polygon ;

: polygon-vertex ( -- ) position get vertices get push ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

USE: sequences : length* length ; USE: lindenmayer

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Lindenmayer string rewriting
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SYMBOL: rules

: segment ( str -- seq )
{ { [ dup "" = ] [ drop [ ] ] }
  { [ dup length* 1 = ] [ f cons ] }
  { [ dup 1 swap nth CHAR: ( = ]
    [ dup CHAR: ) swap index 1 +	! str i
      swap				! i str
      2dup head				! i str head
      -rot tail				! head tail
      segment cons ] }
  { [ t ] [ 1 over head swap 1 swap tail segment cons ] } }
cond ;

: lookup ( str -- str ) 1 over head rules get hash dup [ nip ] [ drop ] if ;

: rewrite ( str -- str ) segment [ lookup ] map concat ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Lindenmayer string interpretation
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SYMBOL: command-table

: segment-command ( seg -- command ) 1 swap head ;

: segment-parameter ( seg -- parameter )
dup length* 1 - 2 swap rot subseq parse call ;

: segment-parts ( seg -- param command )
dup segment-parameter swap segment-command ;

: exec-command ( str -- ) command-table get hash dup [ call ] [ drop ] if ;

: exec-command-with-param ( param command -- )
command-table get hash dup [ last call ] [ 2drop ] if ;

: (interpret) ( seg -- )
dup length* 1 =
[ exec-command ] [ segment-parts exec-command-with-param ] if ;

: interpret ( str -- ) segment [ (interpret) ] each ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Lparser dialect
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SYMBOL: angle
SYMBOL: length
SYMBOL: thickness
SYMBOL: color-index

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

DEFER: set-thickness
DEFER: set-color-index

TUPLE: state position orientation angle length thickness color-index ;

SYMBOL: states V{ } states set-global

: save-state ( -- )
position get orientation get angle get length get thickness get
color-index get <state>
states get push ;

: restore-state ( -- )
states get pop
dup state-position    position set-global
dup state-orientation orientation set-global
dup state-length      length set-global
dup state-angle       angle set-global
dup state-color-index set-color-index
dup state-thickness   set-thickness
drop ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: scale-length ( m -- ) length get * length set-global ;

: scale-angle ( m -- ) angle get * angle set-global ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SYMBOL: color-table

{ { 0 0 0 } ! black
  { 0.5 0.5 0.5 } ! grey
  { 1 0 0 } ! red
  { 1 1 0 } ! yellow
  { 0 1 0 } ! green
  { 0.250 0.878 0.815 } ! turquoise
  { 0 0 1 } ! blue
  { 0.627 0.125 0.941 } ! purple
  { 0 0.392 0 } ! dark green
  { 0.0 0.807 0.819 } ! dark turquoise
  { 0.0 0.0 0.545 } ! dark blue
  { 0.580 0.0 0.827 } ! dark purple
  { 0.545 0.0 0.0 } ! dark red
  { 0.25 0.25 0.25 } ! dark grey
  { 0.75 0.75 0.75 } ! medium grey
  { 1 1 1 } ! white
} color-table set-global

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

USE: sequences

: >float-array ( seq -- )
dup length "float" <c-array> swap dup length >array
[ pick set-float-nth ] 2each ;

USE: lindenmayer

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: material-color ( r g b -- )
3array 1.0 add >float-array
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot glMaterialfv ;

: set-color-index ( i -- )
dup color-index set-global color-table get nth dup
first3 glColor3f first3 material-color ;

: inc-color-index ( -- ) color-index get 1 + set-color-index ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: set-thickness ( i -- ) dup thickness set-global glLineWidth ;

: scale-thickness ( m -- ) thickness get * 0.5 max set-thickness ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: -rotate-y neg rotate-y ;
: -rotate-x neg rotate-x ;
: -rotate-z neg rotate-z ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: lparser-dialect ( -- )

1 length set-global   45 angle set-global   1 thickness set-global
2 set-color-index

H{ { "+" [ angle get     rotate-y ] }
!  { "-" [ angle get neg rotate-y ] }
   { "-" [ angle get    -rotate-y ] }
   { "&" [ angle get     rotate-x ] }
!  { "^" [ angle get neg rotate-x ] }
   { "^" [ angle get    -rotate-x ] }
   { "<" [ angle get     rotate-z ] }
!  { ">" [ angle get neg rotate-z ] }
   { ">" [ angle get    -rotate-z ] }
   { "|" [ 180.0         rotate-y ] }
   { "%" [ 180.0         rotate-z ] }

   { "F" [ length get     draw-forward ] }
   { "Z" [ length get 2 / draw-forward ] }
   { "f" [ length get     move-forward ] }
   { "z" [ length get 2 / move-forward ] }
   { "g" [ length get     sneak-forward ] }

   { "." [ polygon-vertex ] }
   { "[" [ save-state ] }
   { "]" [ restore-state ] }
   { "{" [ start-polygon ] }
   { "}" [ finish-polygon ] }

   { "/" [ 1.1 scale-length ] }
   { "'" [ 0.9 scale-length ] }
   { ";" [ 1.1 scale-angle ] }
   { ":" [ 0.9 scale-angle ] }
!   { "?" [ thickness get 1.4 * thickness set ] }
!   { "!" [ thickness get 0.7 * thickness set ] }
   { "?" [ 1.4 scale-thickness ] }
   { "!" [ 0.7 scale-thickness ] }

!   { "c" [ inc-color-index ] }
   { "c" [ color-index get 1 + set-color-index ] }

} command-table set-global ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Examples
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SYMBOL: axiom
SYMBOL: result

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: koch ( -- ) lparser-dialect   90 angle set-global

H{ { "K" "[[a|b] '(0.41)f'(2.439) |<(60) [a|b]]" }
   { "k" "[ c'(0.5) K]" }
   { "a" "[d <(120) d <(120) d ]" }
   { "b" "e" }
   { "e" "[^ '(.2887)f'(3.4758) &(180)      +z{.-(120)f-(120)f}]" }
   { "d" "[^ '(.2887)f'(3.4758) &(109.5111) +zk{.-(120)f-(120)f}]" }
} rules set-global

"K" axiom set-global ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: spiral-0 ( -- ) lparser-dialect  10 angle set-global  5 thickness set-global

"[P]|[P]" axiom set-global

H{ { "P" "[A]>>>>>>>>>[cB]>>>>>>>>>[ccC]>>>>>>>>>[cccD]" }
   { "A" "F+;'A" }
   { "B" "F!+F+;'B" }
   { "C" "F!^+F^+;'C" }
   { "D" "F!>^+F>^+;'D" }
} rules set-global ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: tree-5 ( -- ) lparser-dialect   5 angle set-global   1 thickness set-global

"c(4)FFS" axiom set-global

H{ { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
   { "R" "[Ba]" }
   { "a" "$tF[Cx]Fb" }
   { "b" "$tF[Dy]Fa" }
   { "B" "&B" }
   { "C" "+C" }
   { "D" "-D" }

   { "x" "a" }
   { "y" "b" }

   { "F" "'(1.25)F'(.8)" }
} rules set-global ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: abop-1 ( -- ) lparser-dialect   45 angle set-global   5 thickness set-global

H{ { "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
   { "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
   { "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }

   { "L" "~c(8){+(30)f-(120)f-(120)f}" }
} rules set-global

"c(12)FFAL" axiom set-global ;