home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / logo / powerlogo / utilities / turtle-shell < prev    next >
Text File  |  1992-11-10  |  34KB  |  1,095 lines
  1.  
  2. ;  ***************************************************************
  3. ;  ***   Turtle Shell
  4. ;  ***************************************************************
  5.  
  6. if buriedp "turtle-names [ unbury "turtle-names ] [ ]
  7.  
  8. make "turtle-names [
  9.    turtle-names
  10.    turtle endturtle tg-menu
  11.    tg-menu-demon tg-mouse-demon tg-close-demon
  12.    color-window color-pen-box click-color-window mode
  13.    mouse-window click-mouse-window mouse-tool addmouse
  14.    mouse-tool-draw mouse-tool-brush mouse-tool-oneline mouse-tool-linkline
  15.    mouse-tool-ellipse mouse-tool-position mouse-tool-block
  16.    mouse-tool-record while-mouse-down
  17.    action-window click-action-window action-tool addaction
  18.    poly circle playback set-record record
  19.    palette-window pattern
  20.    setghosts setchecks movechecks movecheck
  21.    reset-menus attach-menus drawbox
  22.    ct cs fs ts ss ]
  23.  
  24. unbury :turtle-names
  25.  
  26. make "tg-window @1
  27. make "tg-mouse-window @1
  28. make "tg-color-window @1
  29. make "tg-palette-window @1
  30. make "tg-action-window @1
  31. make "size 1
  32.  
  33. pprop "startup-data "keepers se  [  tg-data
  34.                                     tg-window
  35.                                     tg-mouse-window
  36.                                     tg-color-window
  37.                                     tg-palette-window
  38.                                     tg-action-window
  39.                                     tg-screen
  40.                                     tg-turtle
  41.                                     tg-mouse-tool
  42.                                     tg-color-pen
  43.                                     size
  44.                                  ] gprop "startup-data "keepers
  45.  
  46.  
  47. pprop "tg-data "hogmem 300000
  48.  
  49.  
  50. ; *********************************************************************
  51. ;  turtle         ( view-modes bit-planes )
  52. ;     Prepare screen, window, and turtle for turtle graphics.
  53.  
  54. make "turtle [
  55.    procedure [ [ ] [ :t-v :t-d ] [ :t-vm :t-cl :t-i :t-sx :t-sy :t-w :t-h :t-on ] ]
  56.    if numberp :t-v [ ] [ make "t-v 3 ]
  57.    if numberp :t-d [ ] [ make "t-d 3 ]
  58.    make "t-on if = 3 :t-v
  59.                [ [ color-window mouse-window action-window ] ]
  60.                [ [ ] ]
  61.    make "t-cl gprop "tg-data "color-list
  62.    if emptyp :t-cl
  63.    [  make "t-i 19
  64.       repeat 3 [ make "t-cl fput rgb @0 :t-i :t-cl dec "t-i ]
  65.       make "t-cl ( se
  66.          [  [  0  0  0 ] [ 14 14 14 ] [ 7 0 7 ] [ 0 15 0 ]
  67.             [ 15 0 0 ] [ 0 0 15 ] [ 11 4 0 ] [ 15 15 0 ]
  68.             [ 6 2 0 ] [ 15 11 8 ] [ 1 14 15 ] [ 14 11 0 ]
  69.             [ 5 5 15 ] [ 9 2 15 ] [ 0 6 3 ] [ 15 0 15 ]
  70.             [ 14 8 5 ] ]
  71.          :t-cl
  72.          [  [ 10 0 4 ] [ 10 2 5 ] [ 9 4 6 ] [ 9 6 7 ]
  73.             [ 11 9 10 ] [ 12 12 12 ] [ 10 10 10 ] [ 8 8 8 ]
  74.             [ 7 7 7 ] [ 5 5 5 ] [ 3 3 3 ] [ 15 15 15 ] ] )
  75.       pprop "tg-data "color-list :t-cl ] [ ]
  76.    if namep "tg-screen
  77.    [  if memberp :tg-screen screenlist
  78.       [  make "t-cl [ ]
  79.          make "t-i 31
  80.          repeat 32 [ make "t-cl fput rgb :tg-screen :t-i :t-cl dec "t-i ]
  81.          pprop "tg-data "color-list :t-cl
  82.          make "t-on ( se  if memberp :tg-color-window windowlist
  83.                              [ [ color-window ] ] [ [ ] ]
  84.                           if memberp :tg-mouse-window windowlist
  85.                              [ [ mouse-window ] ] [ [ ] ]
  86.                           if memberp :tg-action-window windowlist
  87.                              [ [ action-window ] ] [ [ ] ]
  88.                           if memberp :tg-palette-window windowlist
  89.                              [ [ palette-window ] ] [ [ ] ] )
  90.          closescreen :tg-screen ] [ ] ] [ ]
  91.    pprop "tg-data "modes :t-v
  92.    pprop "tg-data "depth :t-d
  93.    make "t-vm if = :t-d 6 [ + 4 :t-v ] [ :t-v ]
  94.    recycle
  95.    make "tg-screen ( openscreen :t-vm :t-d )
  96.    make "tg-window ( openwindow :tg-screen 64 [ ] )
  97.    make "tg-turtle openturtle :tg-window
  98.    putprop "startup-data "screen :tg-screen
  99.    make "t-i 0
  100.    repeat 32
  101.    [  setrgb :tg-screen :t-i first :t-cl
  102.       make "t-cl bf :t-cl
  103.       inc "t-i ]
  104.    make "t-w peek -2 psum :tg-screen 12
  105.    make "t-h peek -2 psum :tg-screen 14
  106.    pprop "tg-data "width :t-w
  107.    pprop "tg-data "height :t-h
  108.    make "t-sx if <= 640 :t-w [ - :t-w 292 ] [ :t-w ]
  109.    make "t-sy if <= 400 :t-h [ 54 ] [ 46 ]
  110.    ( movecommand :tg-screen 0 - :t-h :t-sy
  111.                             :t-sx :t-sy )
  112.    pprop "tg-data "drawmode 1
  113.    pprop "tg-data "pattern 1
  114.    pprop "tg-data "mouse-tool-number 1
  115.    whenmenu [ tg-menu-demon getmenu ]
  116.    whenmouse [ tg-mouse-demon ]
  117.    whenclose [ tg-close-demon getclose ]
  118.    attach-menus @0
  119.    attach-menus :tg-window
  120.    mode 3
  121.    pattern 1
  122.    mouse-tool 1
  123.    run :t-on ]
  124.  
  125.  
  126. make "endturtle [
  127.    procedure [ [ ] [ ] [ :t-cl :t-i ] ]
  128.    if namep "tg-screen
  129.    [  if memberp :tg-screen screenlist
  130.       [  closewindow :tg-window
  131.          ( movecommand @0 0 11 550 189 )
  132.          make "t-cl [ ]
  133.          make "t-i 31
  134.          repeat 32 [ make "t-cl fput rgb :tg-screen :t-i :t-cl dec "t-i ]
  135.          pprop "tg-data "color-list :t-cl
  136.          closescreen :tg-screen ] [ ] ] [ ]
  137.    pprop "startup-data "screen @0
  138.    whenmenu [ comm-menu-demon getmenu ]
  139.    setmenu @0 :comm-menu
  140.    whenmouse [ ]
  141.    whenclose [ ] ]
  142.  
  143.  
  144. ; *********************************************************************
  145. ; *** Menu data
  146. ; *********************************************************************
  147.  
  148. make "tg-menu [
  149.  
  150.    \ LOGO\ 
  151.       [ \ Load ]
  152.       [ \ Save ]
  153.       [ \ Edit E ]
  154.       [ \ Edit\ File ]
  155.       [ \ Turtle\ Off ]
  156.       [ \ Interrupt ]
  157.       [ \ Top\ Level G ]
  158.       [ \ Quit ]
  159.  
  160.    \ Picture\  
  161.       [ \ Load ]
  162.       [ \ Save ]
  163.       [ \ Pattern
  164.          [ \ \ xxxxxxxxxxxxxxxx ]
  165.          [ \ \ xxxxxxxx-------- ]
  166.          [ \ \ xxxx----xxxx---- ]
  167.          [ \ \ xx--xx--xx--xx-- ]
  168.          [ \ \ x-x-x-x-x-x-x-x- ]
  169.          [ \ \ x---x---x---x--- ]
  170.          [ \ \ x-------x------- ]
  171.          [ \ \ -xxx-xxx-xxx-xxx ]
  172.          [ \ \ -xxxxxxx-xxxxxxx ]
  173.          [ \ \ x--------------- ]
  174.          [ \ \ xx-------------- ]
  175.          [ \ \ xxxx------------ ]
  176.          [ \ \ xxxxxxxxxxxx---- ]
  177.          [ \ \ -------xxx---xxx ]
  178.          [ \ \ xxxxxxx---xxx--- ] ]
  179.       [ \ Mouse ]
  180.       [ \ Action ]
  181.       [ \ Pen
  182.          [ \ \ Up U ]
  183.          [ \ \ Down D ]
  184.          [ \ \ JAM1 ]
  185.          [ \ \ JAM2 ]
  186.          [ \ \ COMP ] ]
  187.       [ \ Windows
  188.          [ \ Full F ]
  189.          [ \ Split S ]
  190.          [ \ Text T ]
  191.          [ \ Palette P ]
  192.          [ \ Pen\ Color C ]
  193.          [ \ Mouse M ]
  194.          [ \ Action A ] ]
  195.       [ \ Colors
  196.          [ \ \ 2 ]
  197.          [ \ \ 4 ]
  198.          [ \ \ 8 ]
  199.          [ \ \ 16 ]
  200.          [ \ \ 32 ]
  201.          [ \ \ 64 ] ]
  202.       [ \ Size
  203.          [ \ \ 320x200 ]
  204.          [ \ \ 640x200 ]
  205.          [ \ \ 320x400 ]
  206.          [ \ \ 640x400 ] ] ]
  207.  
  208.  
  209. ; *********************************************************************
  210. ; *** Demons
  211. ; *********************************************************************
  212.  
  213.  
  214. make "tg-menu-demon [
  215.    procedure [ [ :tmd-menu-data ] [ ]
  216.                [ :tmd-menu-item :tmd-menu-subitem :tmd-menu-temp ] ]
  217.    make "tmd-menu-item item 3 :tmd-menu-data
  218.    make "tmd-menu-subitem item 4 :tmd-menu-data
  219.  
  220.    switch item 2 :tmd-menu-data
  221.    [
  222.       [  switch :tmd-menu-item
  223.          [
  224.             [  make "tmd-menu-temp ( filerequest "Load\ File\ \ -\  )
  225.                ( intuition 6 :tg-screen )
  226.                if emptyp :tmd-menu-temp [ ]
  227.                   [ load :tmd-menu-temp ] ]
  228.             [  make "tmd-menu-temp ( filerequest "Save\ File\ \ -\  )
  229.                ( intuition 6 :tg-screen )
  230.                if emptyp :tmd-menu-temp [ ]
  231.                [  save  :tmd-menu-temp
  232.                         remove-quick   se    gprop "startup-data "keepers
  233.                                              [  s-item
  234.                                                 s-list
  235.                                                 tmd-menu-data
  236.                                                 tmd-menu-item
  237.                                                 tmd-menu-subitem
  238.                                                 tmd-menu-temp ]
  239.                                        namelist ] ]
  240.             [ edit ]
  241.             [ edf [ ] ]
  242.             [ endturtle type "? ]
  243.             [ system 11 interrupt ]
  244.             [ toplevel ]
  245.             [ clean-quit ] ] ]
  246.  
  247.       [  switch :tmd-menu-item
  248.          [
  249.             [  make "tmd-menu-temp ( filerequest "Load\ Picture\ \ -\  )
  250.                ( intuition 6 :tg-screen )
  251.                if emptyp :tmd-menu-temp [ ]
  252.                [  ( intuition 11 :tg-window )
  253.                   wait 0.1
  254.                   loadimage :tg-window :tmd-menu-temp ] ]
  255.  
  256.             [  make "tmd-menu-temp ( filerequest "Save\ Picture\ \ -\  )
  257.                ( intuition 6 :tg-screen )
  258.                if emptyp :tmd-menu-temp [ ]
  259.                [  ( intuition 11 :tg-window )
  260.                   wait 0.1
  261.                   saveimage :tg-window :tmd-menu-temp
  262.                   ( saveicon :tmd-menu-temp " [ FILETYPE=ilbm ] ) ] ]
  263.  
  264.             [ pattern :tmd-menu-subitem ]
  265.  
  266.             [ mouse-tool :tmd-menu-subitem ]
  267.  
  268.             [ action-tool :tmd-menu-subitem ]
  269.  
  270.             [ mode :tmd-menu-subitem ]
  271.  
  272.             [  switch :tmd-menu-subitem
  273.                [  [ fs ]
  274.                   [ ss ]
  275.                   [ ts ]
  276.                   [ palette-window ]
  277.                   [ color-window ]
  278.                   [ mouse-window ]
  279.                   [ action-window ] ] ]
  280.  
  281.             [  ( turtle gprop "tg-data "modes :tmd-menu-subitem )
  282.                type "? ]
  283.  
  284.             [  ( turtle - :tmd-menu-subitem 1 gprop "tg-data "depth )
  285.                type "? ]
  286.          ]
  287.       ]
  288.    ]
  289. ]
  290.  
  291.  
  292. make "tg-mouse-demon [
  293.    procedure [ [ ] [ ] [ :tmd-md :tmd-window :x :y :tmd-td ] ]
  294.    dowhile [ make "tmd-md getmouse ] [ mousep ]
  295.    make "tmd-window first :tmd-md
  296.    make "x item 2 :tmd-md
  297.    make "y item 3 :tmd-md
  298.    cond
  299.    [  [ = :tg-window :tmd-window ]
  300.       [  make "tmd-td downp :tg-turtle
  301.          pu
  302.          run :tg-mouse-tool
  303.          if :tmd-td [ pd ] [ ] ]
  304.       [ = :tg-color-window :tmd-window ]
  305.          [ click-color-window :x :y ]
  306.       [ = :tg-mouse-window :tmd-window ]
  307.          [ click-mouse-window :x :y ]
  308.       [ = :tg-action-window :tmd-window ]
  309.          [ click-action-window :x :y ]
  310.    ]
  311. ]
  312.  
  313.  
  314. make "tg-close-demon [
  315.    procedure [ [ :tcd-window ] ]
  316.    if memberp :tcd-window windowlist [ closewindow :tcd-window ] [ ] ]
  317.  
  318.  
  319. ; *********************************************************************
  320. ; *** Pen Color
  321. ; *********************************************************************
  322.  
  323.  
  324. make "color-window [
  325.    procedure [ [ ] [ ] [ :cw-sx :cw-sy :cw-c :cw-x :cw-y
  326.                          :cw-x2 :cw-y2 :cw-i ] ]
  327.    if memberp :tg-color-window windowlist
  328.    [  ( intuition 11 :tg-color-window )
  329.       stop ] [ ]
  330.    make "cw-sx item gprop "tg-data "depth [ 96 48 24 24 12 12 ]
  331.    make "cw-sy item gprop "tg-data "depth [ 24 24 24 12 12  6 ]
  332.    make "cw-x -   gprop "tg-data "width
  333.                if < 600 gprop "tg-data "width [ 290 ] [ 200 ]
  334.    make "cw-y - gprop "tg-data "height 65
  335.    make "tg-color-window ( openwindow  :tg-screen
  336.                                        7
  337.                                        [ Pen Color ]
  338.                                        :cw-x :cw-y
  339.                                        200 65 )
  340.    attach-menus :tg-color-window
  341.  
  342.    setpen :tg-color-window 1
  343.    move :tg-color-window 17 19
  344.    text :tg-color-window [ PU ]
  345.    move :tg-color-window 55 19
  346.    text :tg-color-window [ PD ]
  347.    move :tg-color-window 85 19
  348.    text :tg-color-window [ JAM1 ]
  349.    move :tg-color-window 123 19
  350.    text :tg-color-window [ JAM2 ]
  351.    move :tg-color-window 161 19
  352.    text :tg-color-window [ COMP ]
  353.    move :tg-color-window 20 33
  354.    text :tg-color-window [ FG ]
  355.    move :tg-color-window 80 33
  356.    text :tg-color-window [ BG ]
  357.    move :tg-color-window 140 33
  358.    text :tg-color-window [ AO ]
  359.  
  360.    setpen :tg-color-window ( pen :tg-window 0 )
  361.    rectfill :tg-color-window 40 25 60 35
  362.    setpen :tg-color-window ( pen :tg-window 1 )
  363.    rectfill :tg-color-window 100 25 120 35
  364.    setpen :tg-color-window ( pen :tg-window 2 )
  365.    rectfill :tg-color-window 160 25 180 35
  366.  
  367.    make "cw-i 0
  368.    make "cw-y 39
  369.    make "cw-y2 + 38 :cw-sy
  370.    while [ < :cw-y 62 ]
  371.    [  make "cw-x 4
  372.       make "cw-x2 + 3 :cw-sx
  373.       while [ < :cw-x 192 ]
  374.       [  setpen :tg-color-window :cw-i
  375.          rectfill :tg-color-window :cw-x :cw-y :cw-x2 :cw-y2
  376.          inc "cw-i
  377.          make "cw-x + :cw-sx :cw-x
  378.          make "cw-x2 + :cw-sx :cw-x2 ]
  379.       make "cw-y + :cw-sy :cw-y
  380.       make "cw-y2 + :cw-sy :cw-y2 ]
  381.  
  382.    setpen :tg-color-window 30
  383.    drawbox :tg-color-window 5 11 36 10
  384.    drawbox :tg-color-window 43 11 36 10
  385.    drawbox :tg-color-window 81 11 36 10
  386.    drawbox :tg-color-window 119 11 36 10
  387.    drawbox :tg-color-window 157 11 36 10
  388.  
  389.    drawbox :tg-color-window 15 23 50 14
  390.    drawbox :tg-color-window 75 23 50 14
  391.    drawbox :tg-color-window 135 23 50 14
  392.  
  393.    setpen :tg-color-window 31
  394.    drawbox :tg-color-window + 5 if downp :tg-turtle [ 38 ] [ 0 ] 11 36 10
  395.    drawbox :tg-color-window + 43 * 38 gprop "tg-data "drawmode 11 36 10
  396.  
  397.    make "tg-color-pen 0
  398.    color-pen-box 0
  399. ]
  400.  
  401.  
  402. make "color-pen-box [
  403.    procedure [ [ :cpb-c ] [ ] [ :cpb-x ] ]
  404.    setpen :tg-color-window 30
  405.    make "cpb-x + 15 * 60 :tg-color-pen
  406.    drawbox :tg-color-window :cpb-x 23 50 14
  407.    setpen :tg-color-window 31
  408.    make "cpb-x + 15 * 60 :cpb-c
  409.    drawbox :tg-color-window :cpb-x 23 50 14
  410.    make "tg-color-pen :cpb-c ]
  411.  
  412.  
  413. make "click-color-window [
  414.    procedure [ [ :ccw-x :ccw-y ] [ ] [ :ccw-c ] ]
  415.    cond
  416.    [  [ >>= 24 36 :ccw-y ]
  417.       [  cond
  418.          [  [ >>= 15 65 :ccw-x ] [ color-pen-box 0 ]
  419.             [ >>= 75 125 :ccw-x ] [ color-pen-box 1 ]
  420.             [ >>= 135 185 :ccw-x ] [ color-pen-box 2 ] ] ]
  421.       [ and >>= 39 62 :ccw-y >>= 4 195 :ccw-x ]
  422.       [  make "ccw-c readpixel :tg-color-window :ccw-x :ccw-y
  423.          ( setpen :tg-window :ccw-c :tg-color-pen )
  424.          if = 2 :tg-color-pen [ ] [ settpn :ccw-c :tg-color-pen ]
  425.          setpen :tg-color-window :ccw-c
  426.          switch + 1 :tg-color-pen
  427.          [  [ rectfill :tg-color-window 40 25 60 35 ]
  428.             [ rectfill :tg-color-window 100 25 120 35 ]
  429.             [ rectfill :tg-color-window 160 25 180 35 ] ] ]
  430.       [ >>= 11 21 :ccw-y ]
  431.       [  cond
  432.          [  [ >>= 5 41 :ccw-x ] [ mode 1 ]
  433.             [ >>= 43 79 :ccw-x ] [ mode 2 ]
  434.             [ >>= 81 117 :ccw-x ] [ mode 3 ]
  435.             [ >>= 119 155 :ccw-x ] [ mode 4 ]
  436.             [ >>= 157 193 :ccw-x ] [ mode 5 ] ] ] ] ]
  437.  
  438.  
  439. make "mode [
  440.    procedure [ [ :m-item ] [ ] [ :m-x ] ]
  441.    if = :m-item 1
  442.    [  pu
  443.       movechecks 2 6 2 1
  444.       if memberp :tg-color-window windowlist
  445.       [  setpen :tg-color-window 30
  446.          drawbox :tg-color-window 43 11 36 10
  447.          setpen :tg-color-window 31
  448.          drawbox :tg-color-window 5 11 36 10 ] [ ]
  449.       stop ] [ ]
  450.    if = :m-item 2
  451.    [  pd
  452.       movechecks 2 6 1 2
  453.       if memberp :tg-color-window windowlist
  454.       [  setpen :tg-color-window 30
  455.          drawbox :tg-color-window 5 11 36 10
  456.          setpen :tg-color-window 31
  457.          drawbox :tg-color-window 43 11 36 10 ] [ ]
  458.       stop ] [ ]
  459.    if memberp :tg-color-window windowlist
  460.    [  setpen :tg-color-window 30
  461.       make "m-x + 43 * 38 gprop "tg-data "drawmode 
  462.       drawbox :tg-color-window :m-x 11 36 10
  463.       setpen :tg-color-window 31
  464.       make "m-x + -33 * 38 :m-item 
  465.       drawbox :tg-color-window :m-x 11 36 10 ] [ ]
  466.    settdm - :m-item 3
  467.    setdrmode :tg-window - :m-item 3
  468.    movechecks 2 6 + 2 gprop "tg-data "drawmode :m-item
  469.    pprop "tg-data "drawmode - :m-item 2 ]
  470.  
  471.  
  472. ; *********************************************************************
  473. ; *** Mouse Tools
  474. ; *********************************************************************
  475.  
  476.  
  477. make "mouse-window [
  478.    procedure [ [ ] [ ] [ :mw-tool-names :mw-sy :mw-c :mw-x :mw-y :mw-i ] ]
  479.    if memberp :tg-mouse-window windowlist
  480.    [  ( intuition 11 :tg-mouse-window )
  481.       stop ] [ ]
  482.    make "mw-tool-names gprop "tg-data "mouse-tool-names
  483.    make "mw-c count :mw-tool-names
  484.    make "mw-sy + 17 * 10 :mw-c
  485.    make "mw-x - gprop "tg-data "width 88
  486.    make "mw-y - gprop "tg-data "height :mw-sy
  487.    make "tg-mouse-window ( openwindow  :tg-screen
  488.                                        7
  489.                                        [ Mouse ]
  490.                                        :mw-x :mw-y
  491.                                        88 :mw-sy )
  492.    attach-menus :tg-mouse-window
  493.  
  494.    setpen :tg-mouse-window 1
  495.    make "mw-i 20
  496.    repeat :mw-c
  497.    [  move :tg-mouse-window 12 :mw-i
  498.       text :tg-mouse-window first :mw-tool-names
  499.       make "mw-tool-names bf :mw-tool-names
  500.       make "mw-i + 10 :mw-i ]
  501.  
  502.    setpen :tg-mouse-window 30
  503.    make "mw-i 12
  504.    repeat :mw-c
  505.    [  drawbox :tg-mouse-window 7 :mw-i 73 10
  506.       make "mw-i + 10 :mw-i ]
  507.  
  508.    setpen :tg-mouse-window 31
  509.    drawbox     :tg-mouse-window
  510.                7
  511.                + 2 * 10 gprop "tg-data "mouse-tool-number
  512.                73
  513.                10 ]
  514.  
  515.  
  516. make "click-mouse-window [
  517.    procedure [ [ :cmw-x :cmw-y ] [ ] [ :cmw-tc :cmw-tn ] ]
  518.    make "cmw-tc count gprop "tg-data "mouse-tools
  519.    make "cmw-tn int / - :cmw-y 4 10
  520.    if > :cmw-tn :cmw-tc
  521.    [  make "cmw-tn :cmw-tc ]
  522.    [  if < :cmw-tn 1 [ make "cmw-tn 1 ] [ ] ]
  523.    mouse-tool :cmw-tn ]
  524.  
  525.  
  526. make "mouse-tool [
  527.    procedure [ [ :mt-item ] ]
  528.    if memberp :tg-mouse-window windowlist
  529.    [  setpen :tg-mouse-window 30
  530.       drawbox :tg-mouse-window 7 + 2 * 10 gprop "tg-data "mouse-tool-number 73 10
  531.       setpen :tg-mouse-window 31
  532.       drawbox :tg-mouse-window 7 + 2 * 10 :mt-item 73 10 ] [ ]
  533.    movechecks 2 4 gprop "tg-data "mouse-tool-number :mt-item
  534.    pprop "tg-data "mouse-tool-number :mt-item
  535.    make "tg-mouse-tool item :mt-item gprop "tg-data "mouse-tools ]
  536.  
  537.  
  538. make "addmouse [
  539.    procedure [ [ :am-tool-name :am-tool ] [ ]
  540.                [ :am-tool-names :am-tools :am-open ] ]
  541.    make "am-tool-names gprop "tg-data "mouse-tool-names
  542.    make "am-tools gprop "tg-data "mouse-tools
  543.    if memberp :am-tool-name :am-tool-names [ ]
  544.    [  make "am-open false
  545.       if namep "tg-mouse-window
  546.       [  if memberp :tg-mouse-window windowlist
  547.          [  make "am-open true
  548.             closewindow :tg-mouse-window ] [ ] ] [ ]
  549.       pprop "tg-data "mouse-tool-names lput :am-tool-name :am-tool-names
  550.       pprop "tg-data "mouse-tools lput :am-tool :am-tools
  551.       repitem     14
  552.                   :tg-menu
  553.                   lput     se    [ ]
  554.                                  word  "\ \  
  555.                                        :am-tool-name
  556.                            item 14 :tg-menu
  557.       if memberp :tg-window windowlist [ reset-menus ] [ ]
  558.       if :am-open [ mouse-window ] [ ] ] ]
  559.  
  560.  
  561. make "mouse-tool-draw [
  562.    procedure [ [ :x :y ] [ ] [ :mtd-md ] ]
  563.    move :tg-window :x :y
  564.    while [  make "mtd-md mouse :tg-window
  565.             = 1 item 3 :mtd-md ]
  566.    [  draw :tg-window first :mtd-md item 2 :mtd-md ]
  567.    settpos wtpos :tg-turtle ]
  568.  
  569. addmouse "Draw [ mouse-tool-draw :x :y ]
  570.  
  571.  
  572. make "mouse-tool-brush [
  573.    procedure [ [ :mtb-size :x1 :y1 ] [ ] [ :x2 :y2 :x3 :y3 :mtb-md ] ]
  574.    make "x2 :x1
  575.    make "y2 :y1
  576.    rectfill :tg-window  - :x2 :mtb-size - :y2 :mtb-size 
  577.                         + :x2 :mtb-size + :y2 :mtb-size
  578.    while [  make "mtb-md mouse :tg-window
  579.             = 1 item 3 :mtb-md ]
  580.    [  make "x3 item 1 :mtb-md
  581.       make "y3 item 2 :mtb-md
  582.       if and = :x2 :x3 = :y2 :y3 [ ]
  583.       [  make "x2 :x3
  584.          make "y2 :y3
  585.          rectfill :tg-window  - :x2 :mtb-size - :y2 :mtb-size 
  586.                               + :x2 :mtb-size + :y2 :mtb-size ] ]
  587.    move :tg-window :x2 :y2
  588.    settpos wtpos :tg-turtle ]
  589.  
  590. ; addmouse "Brush\ 3 [ mouse-tool-brush 1 :x :y ]
  591. ; addmouse "Brush\ 5 [ mouse-tool-brush 2 :x :y ]
  592. addmouse "Brush\ 7 [ mouse-tool-brush 3 :x :y ]
  593.  
  594.  
  595. make "mouse-tool-linkline [
  596.    procedure [ [ :x :y ] ]
  597.    move :tg-window :x :y
  598.    pd
  599.    settpos wtpos :tg-turtle
  600.    pu ]
  601.  
  602. addmouse "LinkLine [ mouse-tool-linkline :x :y ]
  603.  
  604.  
  605. make "mouse-tool-oneline [
  606.    procedure [ [ :x :y ] ]
  607.    while-mouse-down :x :y
  608.    [  setdrmode :tg-window 2 ]
  609.    [  move :tg-window :x2 :y2
  610.       draw :tg-window :x1 :y1 ]
  611.    [  mode + 2 gprop "tg-data "drawmode
  612.       settpos wtpos :tg-turtle
  613.       move :tg-window :x2 :y2
  614.       pd
  615.       settpos wtpos :tg-turtle
  616.       pu ] ]
  617.  
  618. addmouse "OneLine [ mouse-tool-oneline :x :y ]
  619.  
  620.  
  621. make "mouse-tool-ellipse [
  622.    procedure [ [ :x :y ] ]
  623.    while-mouse-down :x :y
  624.    [  setdrmode :tg-window 2 ]
  625.    [  ellipse :tg-window :x1 :y1 abs - :x1 :x2 abs - :y1 :y2 ]
  626.    [  mode + 2 gprop "tg-data "drawmode
  627.       ellipse :tg-window :x1 :y1 abs - :x1 :x2 abs - :y1 :y2
  628.       move :tg-window :x1 :y1
  629.       settpos wtpos :tg-turtle ] ]
  630.  
  631. addmouse "Ellipse [ mouse-tool-ellipse :x :y ]
  632.  
  633.  
  634. make "mouse-tool-block [
  635.    procedure [ [ :x :y ] ]
  636.    while-mouse-down :x :y
  637.    [  setdrmode :tg-window 2 ]
  638.    [  if > :x1 :x2 [ make "x1 :x2 ] [ ]
  639.       if > :y1 :y2 [ make "y1 :y2 ] [ ]
  640.       drawbox :tg-window :x1 :y1 - :x2 :x1 - :y2 :y1 ]
  641.    [  setdrmode :tg-window 0
  642.       rectfill :tg-window :x1 :y1 :x2 :y2
  643.       mode + 2 gprop "tg-data "drawmode
  644.       move :tg-window :x1 :y1
  645.       settpos wtpos :tg-turtle ] ]
  646.  
  647. addmouse "Block [ mouse-tool-block :x :y ]
  648.  
  649.  
  650. addmouse "Flood\ PC [   floodpc :tg-window :x :y
  651.                         move :tg-window :x :y
  652.                         settpos wtpos :tg-turtle ]
  653.  
  654. addmouse "Flood\ OL [   floodol :tg-window :x :y
  655.                         move :tg-window :x :y
  656.                         settpos wtpos :tg-turtle ]
  657.  
  658.  
  659. make "mouse-tool-position [
  660.    procedure [ [ :x :y ] ]
  661.    while-mouse-down :x :y
  662.    [  setdrmode :tg-window 2 ]
  663.    [  move :tg-window :x2 :y2
  664.       draw :tg-window :x1 :y1 ]
  665.    [  settpos wtpos :tg-turtle
  666.       make "x3 first wtpos :tg-turtle
  667.       make "y3 first bf wtpos :tg-turtle
  668.       move :tg-window :x2 :y2
  669.       make "x3 - :x3 first wtpos :tg-turtle
  670.       make "y3 - :y3 first bf wtpos :tg-turtle
  671.       seth toward wtpos :tg-turtle :tg-turtle
  672.       move :tg-window :x1 :y1
  673.       make "size sqrt + * :x3 :x3 * :y3 :y3
  674.       mode + 2 gprop "tg-data "drawmode ] ]
  675.  
  676. addmouse "Position [ mouse-tool-position :x :y ]
  677.  
  678.  
  679. make "set-record [
  680.    procedure [ [ :sr-rec ] ]
  681.    pprop "tg-data "mouse-record :sr-rec ]
  682.  
  683. make "mouse-tool-record [
  684.    procedure [ [ :x1 :y1 ] [ ] [ :mtr-rec :x2 :y2 :x3 :y3 :mtr-md ] ]
  685.    make "mtr-rec fput :size :mtr-rec
  686.    make "mtr-rec fput heading :tg-turtle :mtr-rec
  687.    make "mtr-rec fput wtpos :tg-turtle :mtr-rec
  688.    move :tg-window :x1 :y1
  689.    make "mtr-rec fput wtpos :tg-turtle :mtr-rec
  690.    make "x2 :x1
  691.    make "y2 :y1
  692.    while [  make "mtr-md mouse :tg-window
  693.             = 1 item 3 :mtr-md ]
  694.    [  make "x3 item 1 :mtr-md
  695.       make "y3 item 2 :mtr-md
  696.       if and = :x2 :x3 = :y2 :y3 [ ]
  697.       [  make "x2 :x3
  698.          make "y2 :y3
  699.          draw :tg-window :x2 :y2
  700.          make "mtr-rec fput wtpos :tg-turtle :mtr-rec ] ]
  701.    move :tg-window first twpos :tg-turtle item 2 twpos :tg-turtle
  702.    set-record :mtr-rec ]
  703.  
  704. addmouse "Record [ mouse-tool-record :x :y ]
  705.  
  706.  
  707. make "while-mouse-down [
  708.    procedure [ [ :x1 :y1 :wmd-prep :wmd-rough :wmd-fine ] [ ]
  709.                [ :x2 :y2 :x3 :y3 :wmd-md ] ]
  710.    run :wmd-prep
  711.    make "x2 :x1
  712.    make "y2 :y1
  713.    run :wmd-rough
  714.    while [  make "wmd-md mouse :tg-window
  715.             = 1 item 3 :wmd-md ]
  716.    [  make "x3 item 1 :wmd-md
  717.       make "y3 item 2 :wmd-md
  718.       if and = :x2 :x3 = :y2 :y3 [ ]
  719.       [  run :wmd-rough
  720.          make "x2 :x3
  721.          make "y2 :y3
  722.          run :wmd-rough ] ]
  723.    run :wmd-rough
  724.    run :wmd-fine ]
  725.  
  726.  
  727. ; *********************************************************************
  728. ; *** Action Tools
  729. ; *********************************************************************
  730.  
  731.  
  732. make "action-window [
  733.    procedure [ [ ] [ ] [ :cw-tool-names :cw-sy :cw-c :cw-x :cw-y :cw-i ] ]
  734.    if memberp :tg-action-window windowlist
  735.    [  ( intuition 11 :tg-action-window )
  736.       stop ] [ ]
  737.    make "cw-tool-names gprop "tg-data "action-tool-names
  738.    make "cw-c count :cw-tool-names
  739.    make "cw-sy + 17 * 10 :cw-c
  740.    make "cw-x - gprop "tg-data "width 88
  741.    make "cw-y ( -    gprop "tg-data "height
  742.                      :cw-sy
  743.                      if <= 400 gprop "tg-data "height 
  744.                      [  + 19 * 10 count gprop "tg-data "mouse-tool-names ]
  745.                      [ 0 ] )
  746.    make "tg-action-window ( openwindow   :tg-screen
  747.                                           7
  748.                                           [ Action ]
  749.                                           :cw-x :cw-y
  750.                                           88 :cw-sy )
  751.    attach-menus :tg-action-window
  752.  
  753.    setpen :tg-action-window 1
  754.    make "cw-i 20
  755.    repeat :cw-c
  756.    [  move :tg-action-window 12 :cw-i
  757.       text :tg-action-window first :cw-tool-names
  758.       make "cw-tool-names bf :cw-tool-names
  759.       make "cw-i + 10 :cw-i ]
  760.  
  761.    setpen :tg-action-window 30
  762.    make "cw-i 12
  763.    repeat :cw-c
  764.    [  drawbox :tg-action-window 7 :cw-i 73 10
  765.       make "cw-i + 10 :cw-i ] ]
  766.  
  767.  
  768. make "click-action-window [
  769.    procedure [ [ :caw-x :caw-y ] [ ]
  770.                [ :caw-md :caw-tools :caw-tc :caw-tn
  771.                  :caw-hit :caw-hit2 :caw-yn ] ]
  772.    make "caw-tools gprop "tg-data "action-tools
  773.    make "caw-tc count :caw-tools
  774.    make "caw-tn int / - :caw-y 4 10
  775.    if ( and >>= 1 :caw-tc :caw-tn >> 7 81 :caw-x )
  776.    [  setpen :tg-action-window 31
  777.       drawbox :tg-action-window 7 + 2 * 10 :caw-tn 73 10
  778.       make "caw-hit true
  779.       make "caw-hit2 true
  780.       while [  make "caw-md mouse :tg-action-window
  781.                = 1 item 3 :caw-md ]
  782.       [  make "caw-x first :caw-md
  783.          make "caw-yn int / - item 2 :caw-md 4 10
  784.          make "caw-hit and = :caw-yn :caw-tn >> 7 81 :caw-x
  785.          if = :caw-hit :caw-hit2 [ ]
  786.          [  setpen :tg-action-window if :caw-hit [ 31 ] [ 30 ]
  787.             drawbox :tg-action-window 7 + 2 * 10 :caw-tn 73 10
  788.             make "caw-hit2 :caw-hit ] ]
  789.       if :caw-hit [ switch :caw-tn :caw-tools ] [ ]
  790.       setpen :tg-action-window 30
  791.       drawbox :tg-action-window 7 + 2 * 10 :caw-tn 73 10 ] [ ] ]
  792.  
  793.  
  794. make "action-tool [
  795.    procedure [ [ :at-item ] ]
  796.    switch :at-item gprop "tg-data "action-tools ]
  797.  
  798.  
  799. make "addaction [
  800.    procedure [ [ :aa-tool-name :aa-tool ] [ ]
  801.                [ :aa-tool-names :aa-tools :aa-open ] ]
  802.    make "aa-tool-names gprop "tg-data "action-tool-names
  803.    make "aa-tools gprop "tg-data "action-tools
  804.    if memberp :aa-tool-name :aa-tool-names [ ]
  805.    [  make "aa-open false
  806.       if namep "tg-action-window
  807.       [  if memberp :tg-action-window windowlist
  808.          [  make "aa-open true
  809.             closewindow :tg-action-window ] [ ] ] [ ]
  810.       pprop "tg-data "action-tool-names lput :aa-tool-name :aa-tool-names
  811.       pprop "tg-data "action-tools lput :aa-tool :aa-tools
  812.       repitem     15
  813.                   :tg-menu
  814.                   lput     se    [ ]
  815.                                  word  "\ 
  816.                                        :aa-tool-name
  817.                            item 15 :tg-menu
  818.       if memberp :tg-window windowlist [ reset-menus ] [ ]
  819.       if :aa-open [ action-window ] [ ] ] ]
  820.  
  821. addaction "Home [ home ]
  822. addaction "Clean [ clean ]
  823. addaction "Clear [ home clean ]
  824.  
  825. addaction "HogMem [
  826.    if emptyp gprop "tg-data "unhogmem
  827.       [ pprop "tg-data "unhogmem system 1 ] [ ]
  828.    ( system 2 gprop "tg-data "hogmem )
  829.    ( recycle 1 ) ]
  830.  
  831. addaction "UnHogMem [
  832.    if emptyp gprop "tg-data "unhogmem [ ]
  833.    [  ( system 2 gprop "tg-data "unhogmem )
  834.       pprop "tg-data "unhogmem [ ]
  835.       recycle
  836.       ( recycle 1 ) ] ]
  837.  
  838. addaction "Recycle [ ( recycle 1 ) ]
  839.  
  840.  
  841. make "playback [
  842.    procedure [ [ :pb-size :pb-rec ] [ ]
  843.                [  :pb-scale :pb-rh :pb-rs :pb-down
  844.                   :pb-sin :pb-cos :pb-tx :pb-ty
  845.                   :pb-x :pb-y :pb-fx :pb-fy :pb-ep :pb-t ] ]
  846.    if > 4 count :pb-rec [ stop ] [ ]
  847.    make "pb-down downp :tg-turtle
  848.    pu
  849.    fd :pb-size
  850.    make "pb-ep tpos :tg-turtle
  851.    bk :pb-size
  852.    make "pb-rec reverse :pb-rec
  853.    make "pb-scale / :pb-size first :pb-rec
  854.    make "pb-rec bf :pb-rec
  855.    make "pb-sin sin - heading :tg-turtle first :pb-rec
  856.    make "pb-cos cos - heading :tg-turtle first :pb-rec
  857.    make "pb-rec bf :pb-rec
  858.    make "pb-fx first first :pb-rec
  859.    make "pb-fy item 2 first :pb-rec
  860.    make "pb-x first tpos :tg-turtle
  861.    make "pb-y first bf tpos :tg-turtle
  862.    make "pb-rec bf :pb-rec
  863.    make "pb-t first :pb-rec
  864.    make "pb-tx - first :pb-t :pb-fx
  865.    make "pb-ty - item 2 :pb-t :pb-fy
  866.    settpos list   +  :pb-x
  867.                      *  :pb-scale
  868.                         +  * :pb-tx :pb-cos
  869.                            * :pb-ty :pb-sin
  870.                   +  :pb-y
  871.                      *  :pb-scale
  872.                         +  * :pb-ty :pb-cos
  873.                            * +- :pb-tx :pb-sin
  874.    make "pb-rec bf :pb-rec
  875.    pd
  876.    while [ not emptyp :pb-rec ]
  877.    [  make "pb-t first :pb-rec
  878.       make "pb-tx - first :pb-t :pb-fx
  879.       make "pb-ty - item 2 :pb-t :pb-fy
  880.       settpos list   +  :pb-x
  881.                         *  :pb-scale
  882.                            +  * :pb-tx :pb-cos
  883.                               * :pb-ty :pb-sin
  884.                      +  :pb-y
  885.                         *  :pb-scale
  886.                            +  * :pb-ty :pb-cos
  887.                               * +- :pb-tx :pb-sin
  888.       make "pb-rec bf :pb-rec ]
  889.    pu
  890.    settpos :pb-ep
  891.    if :pb-down [ pd ] [ ] ]
  892.  
  893.  
  894. make "record [
  895.    procedure [ ]
  896.    output gprop "tg-data "mouse-record ]
  897.  
  898. addaction "PlayBack [ playback :size record ]
  899.  
  900. addaction "MarkPos [ fd :size bk :size ]
  901.  
  902.  
  903. addaction "Text [
  904.    pr [ Enter Text ]
  905.    type ">>
  906.    ( intuition 12 @0 )
  907.    text :tg-window rl ]
  908.  
  909.  
  910. make "poly [
  911.    procedure [ [ :p-size :p-sides ] [ ] [ :a ] ]
  912.    make "a / 360 :p-sides
  913.    repeat :p-sides [ fd :p-size rt :a ] ]
  914.  
  915. make "circle [
  916.    procedure [ [ :c-size ] [ ] ]
  917.    if downp :tg-turtle
  918.    [  pu
  919.       fd :c-size
  920.       rt 91
  921.       pd
  922.       poly * :c-size 0.034906785 180
  923.       pu
  924.       lt 91
  925.       bk :c-size
  926.       pd ] [ ] ]
  927.  
  928. addaction "Circle [ circle :size ]
  929.  
  930.  
  931. ; addaction "TriAngle [ poly :size 3 ]
  932. ; addaction "Square [ poly :size 4 ]
  933. ; addaction "Pentagon [ poly :size 5 ]
  934. ; addaction "Hexagon [ poly :size 6 ]
  935.  
  936. addaction "Star\ 5 [ repeat 5 [ fd :size rt 144 ] ]
  937.  
  938.  
  939. ; *********************************************************************
  940. ; *** Palette Tool
  941. ; *********************************************************************
  942.  
  943.  
  944. make "palette-window [
  945.    procedure [ ]
  946.    if ( palettep :tg-palette-window )
  947.    [  ( intuition 11 :tg-palette-window ) ]
  948.    [  make "tg-palette-window openpalette true :tg-screen
  949.       attach-menus :tg-palette-window ] ]
  950.  
  951.  
  952. ; *********************************************************************
  953. ; *** Subs
  954. ; *********************************************************************
  955.  
  956.  
  957. make "pattern [
  958.    procedure [ [ :p-pn ] [ ] [ :p-pat ] ]
  959.    make "p-pat item :p-pn [
  960.          xxxxxxxxxxxxxxxx
  961.          xxxxxxxx--------
  962.          xxxx----xxxx----
  963.          xx--xx--xx--xx--
  964.          x-x-x-x-x-x-x-x-
  965.          x---x---x---x---
  966.          x-------x-------
  967.          -xxx-xxx-xxx-xxx
  968.          -xxxxxxx-xxxxxxx
  969.          x---------------
  970.          xx--------------
  971.          xxxx------------
  972.          xxxxxxxxxxxx----
  973.          -------xxx---xxx
  974.          xxxxxxx---xxx--- ]
  975.    settlp :p-pat
  976.    setlinept :tg-window :p-pat
  977.    movechecks 2 3 gprop "tg-data "pattern :p-pn
  978.    pprop "tg-data "pattern :p-pn ]
  979.  
  980.  
  981. make "setghosts [
  982.    procedure [ [ :sg-window ] ]
  983.    if or = 1 gprop "tg-data "modes
  984.          = 3 gprop "tg-data "modes
  985.    [  ( intuition 3 :sg-window 2 8 5 )
  986.       ( intuition 3 :sg-window 2 8 6 ) ] [ ]
  987.    if >= gprop "tg-data "depth 5
  988.    [  ( intuition 3 :sg-window 2 9 2 )
  989.       ( intuition 3 :sg-window 2 9 4 ) ] [ ] ]
  990.  
  991.  
  992. make "setchecks [
  993.    procedure [ [ :sc-window ] ]
  994.    ( intuition 13 :sc-window 2 3 gprop "tg-data "pattern )
  995.    ( intuition 13 :sc-window 2 6 if downp :tg-turtle [ 2 ] [ 1 ] )
  996.    ( intuition 13 :sc-window 2 6 + 2 gprop "tg-data "drawmode )
  997.    ( intuition 13 :sc-window 2 4 gprop "tg-data "mouse-tool-number )
  998.    ( intuition 13 :sc-window 2 8 gprop "tg-data "depth )
  999.    ( intuition 13 :sc-window 2 9 + 1 gprop "tg-data "modes ) ]
  1000.  
  1001.  
  1002. make "reset-menus [
  1003.    procedure [ ]
  1004.    attach-menus @0
  1005.    attach-menus :tg-window
  1006.    attach-menus :tg-color-window
  1007.    attach-menus :tg-palette-window
  1008.    attach-menus :tg-mouse-window
  1009.    attach-menus :tg-action-window ]
  1010.  
  1011.  
  1012. make "attach-menus [
  1013.    procedure [ [ :am-window ] ]
  1014.    if ( or  memberp :am-window windowlist
  1015.             = @0 :am-window ( palettep :am-window ) )
  1016.    [  setmenu :am-window :tg-menu
  1017.       setchecks :am-window
  1018.       setghosts :am-window ] [ ] ]
  1019.  
  1020.  
  1021. make "movechecks [
  1022.    procedure [ [ :mc-m :mc-i :mc-fs :mc-ts ] ]
  1023.    movecheck @0                  :mc-m :mc-i :mc-fs :mc-ts
  1024.    movecheck :tg-window          :mc-m :mc-i :mc-fs :mc-ts
  1025.    movecheck :tg-color-window    :mc-m :mc-i :mc-fs :mc-ts
  1026.    movecheck :tg-palette-window  :mc-m :mc-i :mc-fs :mc-ts
  1027.    movecheck :tg-mouse-window    :mc-m :mc-i :mc-fs :mc-ts
  1028.    movecheck :tg-action-window   :mc-m :mc-i :mc-fs :mc-ts ]
  1029.  
  1030.  
  1031. make "movecheck [
  1032.    procedure [ [ :mc-window :mc-m :mc-i :mc-fs :mc-ts ] ]
  1033.    if ( or    memberp :mc-window windowlist
  1034.               = @0 :mc-window ( palettep :mc-window ) )
  1035.    [  ( intuition 14 :mc-window :mc-m :mc-i :mc-fs )
  1036.       ( intuition 13 :mc-window :mc-m :mc-i :mc-ts ) ] [ ] ]
  1037.  
  1038.  
  1039. make "drawbox [
  1040.    procedure [ [ :db-window :db-le :db-te :db-w :db-h ] ]
  1041.    move :db-window :db-le :db-te
  1042.    draw :db-window + :db-le :db-w :db-te
  1043.    draw :db-window + :db-le :db-w + :db-te :db-h
  1044.    draw :db-window :db-le + :db-te :db-h
  1045.    draw :db-window :db-le :db-te ]
  1046.  
  1047.  
  1048. ; *********************************************************************
  1049. ; *** Screen and Windows
  1050. ; *********************************************************************
  1051.  
  1052. ;  clear text
  1053.  
  1054. make "ct [ procedure [ ] cleartext ]
  1055.  
  1056. ;  clear screen
  1057.  
  1058. make "cs [ procedure [ ] home clean ]
  1059.  
  1060. ;  full screen
  1061.  
  1062. make "fs [ procedure [ ] ( intuition 11 :tg-window ) ]
  1063.  
  1064. ;  text screen
  1065.  
  1066. make "ts [ procedure [ ]
  1067.    ( intuition 12 @0 )
  1068.    ( intuition 11 @0 )
  1069.    ( intuition 2 @0 0 0 )
  1070.    wait 0.1
  1071.    ( intuition 8 @0 gprop "tg-data "width gprop "tg-data "height ) ]
  1072.  
  1073.  
  1074. ;  split screen
  1075.  
  1076. make "ss [
  1077.    procedure [ [ ] [ ] [ :ss-w :ss-h :ss-sx :ss-sy ] ]
  1078.    make "ss-w gprop "tg-data "width
  1079.    make "ss-h gprop "tg-data "height
  1080.    make "ss-sx if <= 640 :ss-w [ - :ss-w 292 ] [ :ss-w ]
  1081.    make "ss-sy if <= 400 :ss-h [ 54 ] [ 46 ]
  1082.    ( intuition 12 @0 )
  1083.    ( intuition 11 @0 )
  1084.    ( intuition 10 :tg-window )
  1085.    ( intuition 8 @0 :ss-sx :ss-sy )
  1086.    wait 0.1
  1087.    ( intuition 2 @0 0 - :ss-h :ss-sy ) ]
  1088.  
  1089.  
  1090. ; *********************************************************************
  1091.  
  1092. bury :turtle-names
  1093.  
  1094.  
  1095.