turtle←{⎕ML←1                               ⍝ Flying-turtle graphics.

    ⍺←'F=↑1 +=⌽¯90 -=⌽90 ×=⊖¯90 ÷=⊖90 ∧=⍋¯90 ∨=⍋90'     ⍝ default definitions

    cmds←{                                  ⍝ turtle commands from macro vector
        segs←{(~⍵∊⍺)⊆⍵}                     ⍝ ⍺-separated segments of vector ⍵
        trim←~∘(⊂'')                        ⍝ without null segments
        names vals←↓⍉↑'='segs¨trim' 'segs ⍺ ⍝ defs ⍺ separated at '=' after ' '
        rads←{⍺='↑':⍺ ⍵ ⋄ ⍺,○⍵÷180}         ⍝ degrees to radians
        pair←{(⊃⍵)rads⍎1↓⍵}                 ⍝ command and its numeric argument
        fms tos(names)(pair¨vals),¨⊂'[]'  ⍝ turtle commands dictionary
        (fms⍳⍵∩fms)tos                    ⍝ turtle commands from macro vector
    }                                       ⍝ [tcmd] ← defns ∇ [mcmd]

    draw←{                                  ⍝ polygons from turtle commands

        step←{cmd arg←⍺                     ⍝ one turtle command:
            '↑'≡cmd:arg move ⍵              ⍝ ↑⍵ forward move
            '⌽'≡cmd:arg turn ⍵              ⍝ ⌽⍵ right turn
            '⊖'≡cmd:arg roll ⍵              ⍝ ⊖⍵ clockwise roll
            '⍋'≡cmd:arg pitch ⍵             ⍝ ⍋⍵ upwards pitch
            '['≡cmd:push ⍵                  ⍝ [  turtle state push
            ']'≡cmd:pop ⍵                   ⍝  ] turtle state pop
        }                                   ⍝ :: state ← cmd ∇ state

        move←{(path paths)attd stack←⍵      ⍝ forward ⍺ units
            next(path)+⍺×⊃attd            ⍝ next position
            ((next path)paths)attd stack    ⍝ extended path
        }                                   ⍝ :: state ← units ∇ state

        turn←{paths(head bank)stack←⍵       ⍝ right ⍺ radians
            hnew(⍺,bank)rotn head          ⍝ new heading
            paths(hnew bank)stack           ⍝ new state
        }                                   ⍝ :: state ← rads ∇ state

        roll←{paths(head bank)stack←⍵       ⍝ clockwise ⍵ radians
            bnew((-⍺),head)rotn bank       ⍝ new banking
            paths(head bnew)stack           ⍝ new state
        }                                   ⍝ :: state ← rads ∇ state

        pitch←{paths(head bank)stack←⍵      ⍝ upwards ⍵ radians
            pax((○0.5),head)rotn bank      ⍝ pitch axis normal to head & bank
            attd←↓(⍺,pax)rotnhead bank     ⍝ rotated head and bank vectors
            paths attd stack                ⍝ new state
        }                                   ⍝ :: state ← rads ∇ state

        push←{points attd stack←⍵           ⍝ push turtle state
            (posn path)pathspoints         ⍝ current path and posn
            points attd(posn attd stack)    ⍝ stacked posn and attitude
        }                                   ⍝ :: state ← ∇ state

        pop←{paths _(posn attd stack)←⍵     ⍝ pop turtle state
            ((posn)paths)attd stack       ⍝ new path at popped state
        }                                   ⍝ :: state ← ∇ state

        paths((0 0 0))0                   ⍝ first point on first path
        attd(0 1 0)(0 0 1)                 ⍝ heading and banking
        stack←0                             ⍝ null branching-stack
        ⊃⊃step/(⌽⍵),⊂paths attd stack       ⍝ list of polygon paths lists
    }                                       ⍝ :: paths ← state ∇ cmds

    rotn←{40 bits ⍵}{                       ⍝ ⍺-rotation of points ⍵
        sax←2 1≡+/0 1∘.=|1↓⍺                ⍝ rotation around single axis?
        sax:⍺ rot2 ⍵ ⋄ ⍺ rot3 ⍵             ⍝ quick 2D, or slower 3d, rotation
    }                                       ⍝ :: pmat ← dirn ∇ pmat

    rot2←{                                  ⍝ quicker 2D complex rotation
        a u(⊃⍺)(1↓⍺)                       ⍝ angle and direction
        msk nsk←0 1=⊂|u                     ⍝ masks for rotation plane
        dir←0 Jnsk/1 ¯1 1×u                ⍝ rotation direction ±0J1
        R←{⍉↑9 11○⊂⍵}                       ⍝ real from complex array
        newmsk\R(J/msk/⍵)×*a×dir           ⍝ new orientation via complex arith
        new+nsk\nsk/⍵                       ⍝ rotated points
    }                                       ⍝ :: pmat ← dirn ∇ pmat

    rot3←{                                  ⍝ slower 3D quaternion rotation
        a u(⊃⍺)(1↓⍺)                       ⍝ angle and direction
        C←{J/2 2⍴(⍤1)⍵}                     ⍝ complex (S,2) from real (S,4)
        R←{,⍤2⊢9 11∘.(○⍨)⍨⍵}                ⍝ R 3J4 → 3 4  real parts
        conj←↑((+⊣),(-⊢))/                  ⍝ H-conjugate +⍵ :: [H] ← ∇ [H]
        qC(2○a÷2),u×1○a÷2                  ⍝ rotation quaternion
        0 1 1 1/R q mul(C 0,⍵)mul conj q    ⍝ q×⍵×q*
    }                                       ⍝ :: pmat ← dirn ∇ pmat

    mul←{                                   ⍝ quaternion product ⍺×⍵
        (a b)(c d)←1⊂¨⍺ ⍵                   ⍝ Caley-Dixon
        ⊃,/((a×c)-b×+d)((d×a)+b×+c)         ⍝   construction
    }                                       ⍝ :: [H] ← [H] ∇ [H]

    J←{⍺+⍵×0J1}                             ⍝ 3 J 4 → 3J4
    bits←{(2*-⍺)×⌊0.5+⍵×2*⍺}                ⍝ rounded to ⍺ bits

    points←{                                ⍝ poly Points matrices from lists

        lines←{                             ⍝ vector of lines from list of lists
            matr←{((≢⍵)÷⍺)⍺⍴⍵}              ⍝ ⍺-column matrix from vector
            vect←{0≡h t←⍵:⍺ ⋄ (⍺,⊂h)t}    ⍝ vector from list
            trim←{(1<≢¨⍵)/⍵}                ⍝ without single-point polygons
            line←{↑¨⊃,/⍵}{2,/(⊂¨)⌽↓⍵}¨      ⍝ individual poly lines
            line trim 3 matr∘∊¨⌽⍬ vect ⍵    ⍝ vector of raw polygon lines
        }                                   ⍝ :: [pmat] ← ∇ List posn

        centred←{                           ⍝ centred in window
            pts←⊃⍪/⍵                        ⍝ collected points matrix
            0∧.=⊢/pts:⍵-⍤1¨⊂÷∘2(⌈⌿+⌊⌿)pts   ⍝ 2D: envelope centred
            ⍵-⍤1¨⊂pts(pts)⍴1              ⍝ 3D: mid point centred
        }                                   ⍝ :: [pmat] ← ∇ [pmat]

        stretched←{                         ⍝ stretched to fit ⍺% of window
            pts←⊃⍪/⍵                        ⍝ collected points matrix
            0∧.=⊢/pts:⍵×⍺÷⌈/(⌈⌿-⌊⌿)pts      ⍝ 2D: size of enclosing square
            ⍵×⍺÷⌈/(+/(pts×2)*2)*0.5         ⍝ 3D: diameter of enclosing sphere
        }                                   ⍝ :: [pmat] ← % ∇ [pmat]

        ⍺ stretched centred lines ⍵         ⍝ image adjusted to fit window
    }                                       ⍝ :: [pmat] ← % ∇ List posn

    image←{                                 ⍝ display of turtle path

        poly←{                              ⍝ polygon object
            pps←'Sizeable' 'Moveable' 'SysMenu' 'MaxButton' 'MinButton' 'Border'
            f←⎕NEW'Form'({⍵ 0}¨pps)         ⍝ borderless containing-form
            f.(Posn Size)←⍵                 ⍝ form placement: screen top right
            f.Coord←'Pixel'                 ⍝ change prop
            f.(Size←2/720⌊⌈/Size)           ⍝ make form square, max 720 pixels
            f.Coord←'User'                  ⍝ restore proportional coords
            f.onKeyPress←'twist'            ⍝ image-rotation callback
            af.⎕NEW⊂'Static'               ⍝ white backdrop
            a.(YRange XRange)←1 ¯1×⊂50 ¯50  ⍝ +/- 50 square
            a.(Posn Size)←(0 0)(100 100)    ⍝ occupies whole form
            points←'Points'(0 2⍴0)          ⍝ initially 0-sided polygon
            lwidth←'Lwidth' 4               ⍝ slightly thicker lines
            a.⎕NEW'Poly'(points lwidth)     ⍝ polygon object
        }                                   ⍝ :: Static ← ∇ Posn Size

        twist(○÷¯180÷5){form msg key←3↑⍵   ⍝ 5° image-rotation callback
            key≡'EP':⎕NQ form'Close'        ⍝ callback: Esc to quit
            D=2:                            ⍝ 2D: no twisting or zooming
            put←{pp.(Points FCol)←colour ⍺} ⍝ visible 2D projection
            zoom←{PNTS put Z∘←50⌊Z+⍵×10}    ⍝ zoom ±10 units                 !!!
            |z('bf'⍳⊂key)⊃¯1 1 0:zoom z    ⍝ b:backwards f:forwards
            keys('UDLR',¨'C'),'zx'         ⍝ ijk-rotation keys
            dirs←2/=∘⊂⍨⍳3                   ⍝ directions 1 0 0, 0 1 0, 0 0 1
            0≡dirn(keys⍳⊂key)dirs,0:      ⍝ chosen direction ignoring bad key
            rads←⍺⍺×1-2×(key)∊'LUz'        ⍝ +/- value
            PNTS put PNTS rot2¨⍨←⊂rads,dirn ⍝ display of updated 3D points   !!!
        }                                   ⍝ :: Form ∇ msg

        colour←{                            ⍝ coloured, orientated lines
            proj←{⌽¨2↑⍤1¨pers ⍵}            ⍝ projection onto x-y plane
            pers←{⍵×⍤1 0¨0.998*⊢/¨⍵-Z-50}   ⍝ hint of perspective
            D=2:(proj)(0 0 0∘⊣¨⍵)         ⍝ 2D: all black lines
            depth(⊢-⌊/)((+⌿÷≢)⊢/)¨         ⍝ depth of line mid-points
            greys←{3⍴¨⌊⍵×192÷⌈/⍵}           ⍝ grey lines: 0 to 192, near to far
            ~'⌹'∊S:(proj)(greys depth)  ⍝ mono: lines and grey shades
            sepr←{(⊂¨yrot 7÷60)rot2¨¨⊂⍵}    ⍝ 7cm @ 60cm separation of images
            yrot←{(¯3○⍵÷¯2 2),¨⊂0 1 0}      ⍝ rotations around y-axis
            zoom←{⍵-⍤1¨⊂¯3↑⍺}               ⍝ zoomed in by ⍺ units
            pnts(-Z)zoom¨sepr Z zoom ⍵     ⍝ separated anaglyph-3D images
            clrs(0 255 255)(255 0 0)       ⍝ left and right colours
            ,∘↑¨(proj¨pnts)(pnts⊢¨∘⊂¨clrs)  ⍝ points and colours
        }{                                  ⍝ :: [pnts] [colr] ← [mcmd] ∇ [pmat]
            (⊂⍒+/¨⊢/¨⍵)⌷⍵                   ⍝ sorted far to near, unless tracing
        }⍣(~'⎕'∊S)                          ⍝ :: [pmat] ← ∇ [pmat]

        put←{pp.(FCol Points FCol)←(⊂⊂⍬),⍵} ⍝ rendering of polygon points
        tcputput⍨∘⎕DL∘(5÷≢⍵)               ⍝ puts spread over 5s if tracing
        trace←{tcput∘{↓⍉↑,⍵}¨,\⊂¨↓⍉↑⍵}      ⍝ show turtle progress

        D←3-0∧.=⊢/↑⍪/PNTS←⍵                 ⍝ image points and rank: 2 or 3D
        Z←50                                ⍝ zoom distance for 3D anaglyph
        pppoly(1 50)(50 50)                ⍝ polygon in (top right) window
        0⊣tracecolour('⎕'∊S)⊢⍵:           ⍝ optional display of progress
        0⊣put colour ⍵:                     ⍝ poly lines and colours
        PNTS⊣⎕DQ pp.##.##                   ⍝ ... until Esc to quit
    }                                       ⍝ :: [pmat] ← trace ∇ [pmat]

    S←'⎕⌹⌸'∩⍵                               ⍝ behaviour switches
    lines←95 points drawcmds ⍵~S         ⍝ vector of polygon lines
    '⌸'∊S:lines                             ⍝ ⌸: points only, no display
    1:PNTSimage lines                      ⍝ display of turtle path

    ⍝ state     :=  paths attd stack        ⍝ drawing state
    ⍝   paths   :=  List path               ⍝ list of polygon paths
    ⍝     path  :=  List posn               ⍝ list of point positions
    ⍝   attd    :=  head bank               ⍝ turtle attitude
    ⍝     head  :=  dirn                    ⍝ heading: fwd direction for turtle
    ⍝     bank  :=  dirn                    ⍝ banking: normal to heading
    ⍝   stack   :=  posn attd stack         ⍝ coordinates stack for branching
    ⍝ posn      :=  # # #                   ⍝ position in 3-space
    ⍝ dirn      :=  # # #                   ⍝ unit vector: direction in 3-space
    ⍝ dist      :=  #                       ⍝ scalar distance between points
    ⍝ rads      :=  #                       ⍝ angle in radians
    ⍝ colr      :=  # # #                   ⍝ colour: red green blue: 0-255
    ⍝ pmat      :=  [;# # #]                ⍝ n×3 positions matrix
    ⍝ pnts      :=  [;# #]                  ⍝ n×2 2D projection
    ⍝ List ⍵    :=  ⍵ (List ⍵) | 0          ⍝ 0-terminated cons list of ⍵s
    ⍝ cmds      :=  [tcmd arg | scmd]       ⍝ turtle commands vector
    ⍝ tcmd      :=  '↑' | '⌽' | '⊖' | '⍋'   ⍝ cmds: forward turn roll pitch
    ⍝   arg     :=  dist | rads             ⍝ turtle command argument
    ⍝ scmd      :=  '[' | ']'               ⍝ stack command: push or pop
}
code_colours

test script

Back to: notes

Back to: Workspaces