code guessing, round #110, stage 2 (guessing)

USING: accessors arrays calendar colors kernel math
math.constants math.functions math.parser
math.vectors opengl processing.shapes random sequences timers ui
ui.gadgets ui.gadgets.cartesian ui.gestures ;
IN: art


TUPLE: turtle pdown direction orig position lines ;

: <turtle> ( -- turtle )
    t pi 2 / { 0.0 0.0 } dup [ clone ] bi@ V{ } clone turtle boa ;

<PRIVATE
: line ( turtle a b -- turtle )
    pick pdown>> [
        2array '[ _ suffix! ] change-lines
    ] [ 2drop ] if ; inline
PRIVATE>

: fwd ( turtle steps -- turtle )
    over direction>> [ cos * ] [ sin * ] 2bi 2array
    over position>> [ v+ ] keep [ line ] keepd >>position ;

: trn ( turtle rads -- turtle )
    over direction>> + >>direction ; inline

: set-angle ( turtle rads -- turtle )
    >>direction ; inline

: pdn ( turtle -- turtle ) t >>pdown ; inline
: pup ( turtle -- turtle ) f >>pdown ; inline

CONSTANT: rand-weights { 12 11 10 10 10 10 10 10 10 10 10 11 }
CONSTANT: zoom-factor 1.1
CONSTANT: trans-amt 10

TUPLE: canvas < cartesian turtle scale timer ;

M: canvas graft*
    [ timer>> start-timer ] [ call-next-method ] bi ;

M: canvas ungraft*
    [ timer>> stop-timer ] [ call-next-method ] bi ;

: rand-idx-weighted ( weights -- idx )
    dup dup sum random
    [ [ unclip-slice ] dip swap - dup 0 > ] loop drop
    2length - ;

: next-line ( canvas -- )
    [
        turtle>>
        rand-weights rand-idx-weighted
        rand-weights length / pi 2 * * set-angle 10 fwd
    ] keep swap >>turtle relayout-1 ;

: update-range ( art -- art )
    dup dim>> [ [ -1 * ] keep 2array over scale>> 2 / v*n ] map
    over [ first2 ] dip turtle>> orig>> first2 -rotd
    [ n+v x-range ] 2dip v+n y-range ;

: draw-art ( art -- )
    COLOR: black gl-color
    turtle>> lines>> [ first2 draw-line* ] each ;

: <canvas> ( -- gadget )
    canvas new init-cartesian
        { 800 800 } >>pdim
        <turtle> >>turtle
        1.0 >>scale
        dup '[ _ next-line ] f 7 milliseconds <timer> >>timer
        dup '[ COLOR: white gl-clear _ update-range draw-art ] >>action ;

:: zoom ( art! factor -- )
    art factor over scale>> * >>scale art! ;

:: trans ( art! amt -- )
    art amt over scale>> trans-amt * v*n 
    over [ turtle>> orig>> v+ ] keep turtle>> swap >>orig >>turtle art! ;

canvas H{
    { T{ key-down f f "o" }       [ zoom-factor zoom ] }
    { T{ key-down f f "i" }       [ 1 zoom-factor / zoom ] }
    { T{ key-down f f "UP" }      [ { 0 1 } trans ] }
    { T{ key-down f f "DOWN" }    [ { 0 -1 } trans ] }
    { T{ key-down f f "LEFT" }    [ { -1 0 } trans ] }
    { T{ key-down f f "RIGHT" }   [ { 1 0 } trans ] }
} set-gestures

MAIN-WINDOW: art-window
    { { title "Biased Random Walk" } }
    <canvas> >>gadgets ;

MAIN: art-window

[___,__]=(<$>)                                              {--

The pan is shallower than i thought, and the water          ---
skids on teflon; it's desperate for space and i fumble      ---
to keep it contained                                        ---

By what right can i dare to capture you                     ---
when you can walk one block south and see trees             ---
mottled,                                                    --} <$>
         [fst                                               {--
              by the sunfall                                --}
                            , snd]                          {--
                                   by the set, and there    --} <*>
 are ("shady ","oranges") (&&) ("sunny ","greens");         {--

when my grandmother's dog is too lively to be               ---
persuaded to hold still long enough for a photo             ---

when i can wake up on the coast, and find                   ---
dead leaves with a color like                               ---
wet bike tires, composting perfectly somehow intact         ———

In the city, i walk past someone's lawn decorations         ---
a little bird, an angel, yoshi                              ---
play treats on my eyes intocticating                        --}
         are x _ y = [[x, y]];                              ---
              main = putStr . unlines $ (++) <$> ___ <*> __ {--

The question answers itself, but there's nothing            ---
to find in its depths; read it again and you will           ---
just have read the same thing twice                         --}