type SaState = ( P2, CircleFrac, Double )
type SaPic = ( (Trail R2), (Trail R2) )
type SaWorld = ( SaPic, SaState )
type SaAct = SaState -> SaWorld
bigbang :: Double -> SaWorld
bigbang w = ((mempty,mempty), (origin,0,w))
(>%) :: SaWorld -> SaAct -> SaWorld
((t1,b1),s1) >% f = let ((t2,b2),s2) = f s1 in ((t1<>t2,b2<>b1),s2)
(>%=) :: SaAct -> SaAct -> SaAct
f >%= g = \s1 ->
let ((t2,b2),s2) = f s1 in
let ((t3,b3),s3) = g s2 in
((t2<>t3,b3<>b2),s3)
saVia :: Double -> SaAct
saVia l (p,a,w) =
(
( hrule l # translateX (l/2) # translateY (w/2) # rotate a
, hrule (-l) # translateX (l/2) # translateY (-w/2) # rotate a
)
,
(p .+^ (unitX # scale l # rotate a),a,w)
)
saTo :: SaAct
saTo (p,a,w) =
(
( hrule w # translateX (-w/2) # rotate (-0.125 :: CircleFrac) # scale 0.7071 # translateX (w/2) # rotate a # translate (origin .-. p)
, hrule (-w) # translateX (-w/2) # rotate ( 0.125 :: CircleFrac) # scale 0.7071 # translateX (w/2) # rotate a # translate (origin .-. p)
)
,
(p,a,0)
)
saTurn :: Double -> CircleFrac -> SaAct
saTurn r a' (p,a,w) = let (outr, inr, qu) = if a'>=0 then (r, -w-r, -0.25::CircleFrac) else (-w-r, r, 0.25::CircleFrac) in
(
( arc' outr (a+qu) (a+a'+qu) # translate (unitY # rotate (a+a' )# scale w)
, arc' inr (a+a'+qu) (a+qu) # translate (unitY # rotate (a+a' )# scale w)
)
,
(p,a+a',w)
)
saSplit :: [(Double, SaAct)] -> SaAct
saSplit fs (p,a,w) =
let (placed,_) = ( foldl ( \(l,t) -> \(i,f) -> ( l++[( ( p .+^ (unitY # rotate a # scale (((t+i/2)-0.5)*w)), a, w*i) ,f )],t+i) ) ([],0) fs ) in
let ws = map (\(b,f)-> f b) placed in
((foldl (<>) mempty (map (\((tt,bb),_)->tt<>bb) ws),mempty),(origin,0,0))
p3 = bigbang 5 >% (saVia 10 >%= (saSplit
[ (0.80,(saVia 10 >%= saTo))
, (0.20,saTurn 1 (-0.25) >%= (saVia 2 >%= (saSplit
[ (0.10,saTurn 1 (0.25) >%= (saVia 5 >%= saTo))
, (0.80,(saVia 3 >%= saTo))
, (0.10,saTurn 1 (-0.25) >%= (saVia 5 >%= saTo))
] )))
] ))
pic3 = let p = fst $ p3 in
(strokeT $ close $ (fst p) <> (snd p) ) # fc red
Adrian.