;  ***************************************************************
;  ***   Turtle Shell
;  ***************************************************************

if buriedp "turtle-names [ unbury "turtle-names ] [ ]

make "turtle-names [
   turtle-names
   turtle endturtle tg-menu
   tg-menu-demon tg-mouse-demon tg-close-demon
   color-window color-pen-box click-color-window mode
   mouse-window click-mouse-window mouse-tool addmouse
   mouse-tool-draw mouse-tool-brush mouse-tool-oneline mouse-tool-linkline
   mouse-tool-ellipse mouse-tool-position mouse-tool-block
   mouse-tool-record while-mouse-down
   action-window click-action-window action-tool addaction
   poly circle playback set-record record
   palette-window pattern
   setghosts setchecks movechecks movecheck
   reset-menus attach-menus drawbox
   ct cs fs ts ss ]

unbury :turtle-names

make "tg-window @1
make "tg-mouse-window @1
make "tg-color-window @1
make "tg-palette-window @1
make "tg-action-window @1
make "size 1

pprop "startup-data "keepers se  [  tg-data
                                    tg-window
                                    tg-mouse-window
                                    tg-color-window
                                    tg-palette-window
                                    tg-action-window
                                    tg-screen
                                    tg-turtle
                                    tg-mouse-tool
                                    tg-color-pen
                                    size
                                 ] gprop "startup-data "keepers


pprop "tg-data "hogmem 300000


; *********************************************************************
;  turtle         ( view-modes bit-planes )
;     Prepare screen, window, and turtle for turtle graphics.

make "turtle [
   procedure [ [ ] [ :t-v :t-d ] [ :t-vm :t-cl :t-i :t-sx :t-sy :t-w :t-h :t-on ] ]
   if numberp :t-v [ ] [ make "t-v 3 ]
   if numberp :t-d [ ] [ make "t-d 3 ]
   make "t-on if = 3 :t-v
               [ [ color-window mouse-window action-window ] ]
               [ [ ] ]
   make "t-cl gprop "tg-data "color-list
   if emptyp :t-cl
   [  make "t-i 19
      repeat 3 [ make "t-cl fput rgb @0 :t-i :t-cl dec "t-i ]
      make "t-cl ( se
         [  [  0  0  0 ] [ 14 14 14 ] [ 7 0 7 ] [ 0 15 0 ]
            [ 15 0 0 ] [ 0 0 15 ] [ 11 4 0 ] [ 15 15 0 ]
            [ 6 2 0 ] [ 15 11 8 ] [ 1 14 15 ] [ 14 11 0 ]
            [ 5 5 15 ] [ 9 2 15 ] [ 0 6 3 ] [ 15 0 15 ]
            [ 14 8 5 ] ]
         :t-cl
         [  [ 10 0 4 ] [ 10 2 5 ] [ 9 4 6 ] [ 9 6 7 ]
            [ 11 9 10 ] [ 12 12 12 ] [ 10 10 10 ] [ 8 8 8 ]
            [ 7 7 7 ] [ 5 5 5 ] [ 3 3 3 ] [ 15 15 15 ] ] )
      pprop "tg-data "color-list :t-cl ] [ ]
   if namep "tg-screen
   [  if memberp :tg-screen screenlist
      [  make "t-cl [ ]
         make "t-i 31
         repeat 32 [ make "t-cl fput rgb :tg-screen :t-i :t-cl dec "t-i ]
         pprop "tg-data "color-list :t-cl
         make "t-on ( se  if memberp :tg-color-window windowlist
                             [ [ color-window ] ] [ [ ] ]
                          if memberp :tg-mouse-window windowlist
                             [ [ mouse-window ] ] [ [ ] ]
                          if memberp :tg-action-window windowlist
                             [ [ action-window ] ] [ [ ] ]
                          if memberp :tg-palette-window windowlist
                             [ [ palette-window ] ] [ [ ] ] )
         closescreen :tg-screen ] [ ] ] [ ]
   pprop "tg-data "modes :t-v
   pprop "tg-data "depth :t-d


; ***  changed for AGA no more extra half bright ***
;   make "t-vm if = :t-d 6 [ + 4 :t-v ] [ :t-v ]
   make "t-vm :t-v


   recycle
   make "tg-screen ( openscreen :t-vm :t-d )
   make "tg-window ( openwindow :tg-screen 64 [ ] )
   make "tg-turtle openturtle :tg-window
   putprop "startup-data "screen :tg-screen
   make "t-i 0
   repeat 32
   [  setrgb :tg-screen :t-i first :t-cl
      make "t-cl bf :t-cl
      inc "t-i ]
   make "t-w peek -2 psum :tg-screen 12
   make "t-h peek -2 psum :tg-screen 14
   pprop "tg-data "width :t-w
   pprop "tg-data "height :t-h
   make "t-sx if <= 640 :t-w [ - :t-w 292 ] [ :t-w ]
   make "t-sy if <= 400 :t-h [ 54 ] [ 46 ]
   ( movecommand :tg-screen 0 - :t-h :t-sy
                            :t-sx :t-sy )
   pprop "tg-data "drawmode 1
   pprop "tg-data "pattern 1
   pprop "tg-data "mouse-tool-number 1
   whenmenu [ tg-menu-demon getmenu ]
   whenmouse [ tg-mouse-demon ]
   whenclose [ tg-close-demon getclose ]
   attach-menus @0
   attach-menus :tg-window
   mode 3
   pattern 1
   mouse-tool 1
   run :t-on ]


make "endturtle [
   procedure [ [ ] [ ] [ :t-cl :t-i ] ]
   if namep "tg-screen
   [  if memberp :tg-screen screenlist
      [  closewindow :tg-window
         ( movecommand @0 0 11 550 189 )
         make "t-cl [ ]
         make "t-i 31
         repeat 32 [ make "t-cl fput rgb :tg-screen :t-i :t-cl dec "t-i ]
         pprop "tg-data "color-list :t-cl
         closescreen :tg-screen ] [ ] ] [ ]
   pprop "startup-data "screen @0
   whenmenu [ comm-menu-demon getmenu ]
   setmenu @0 :comm-menu
   whenmouse [ ]
   whenclose [ ] ]


; *********************************************************************
; *** Menu data
; *********************************************************************

make "tg-menu [

   \ LOGO\ 
      [ \ Load ]
      [ \ Save ]
      [ \ Edit E ]
      [ \ Edit\ File ]
      [ \ Turtle\ Off ]
      [ \ Interrupt ]
      [ \ Top\ Level G ]
      [ \ Quit ]

   \ Picture\  
      [ \ Load ]
      [ \ Save ]
      [ \ Pattern
         [ \ \ xxxxxxxxxxxxxxxx ]
         [ \ \ xxxxxxxx-------- ]
         [ \ \ xxxx----xxxx---- ]
         [ \ \ xx--xx--xx--xx-- ]
         [ \ \ x-x-x-x-x-x-x-x- ]
         [ \ \ x---x---x---x--- ]
         [ \ \ x-------x------- ]
         [ \ \ -xxx-xxx-xxx-xxx ]
         [ \ \ -xxxxxxx-xxxxxxx ]
         [ \ \ x--------------- ]
         [ \ \ xx-------------- ]
         [ \ \ xxxx------------ ]
         [ \ \ xxxxxxxxxxxx---- ]
         [ \ \ -------xxx---xxx ]
         [ \ \ xxxxxxx---xxx--- ] ]
      [ \ Mouse ]
      [ \ Action ]
      [ \ Pen
         [ \ \ Up U ]
         [ \ \ Down D ]
         [ \ \ JAM1 ]
         [ \ \ JAM2 ]
         [ \ \ COMP ] ]
      [ \ Windows
         [ \ Full F ]
         [ \ Split S ]
         [ \ Text T ]
         [ \ Palette P ]
         [ \ Pen\ Color C ]
         [ \ Mouse M ]
         [ \ Action A ] ]
      [ \ Colors
         [ \ \ 2 ]
         [ \ \ 4 ]
         [ \ \ 8 ]
         [ \ \ 16 ]
         [ \ \ 32 ]
         [ \ \ 64 ]
;  ***   128 & 256 added for AGA   ***
         [ \ \ 128 ]
         [ \ \ 256 ] ]
      [ \ Size
         [ \ \ 320x200 ]
         [ \ \ 640x200 ]
         [ \ \ 320x400 ]
         [ \ \ 640x400 ] ] ]


; *********************************************************************
; *** Demons
; *********************************************************************


make "tg-menu-demon [
   procedure [ [ :tmd-menu-data ] [ ]
               [ :tmd-menu-item :tmd-menu-subitem :tmd-menu-temp ] ]
   make "tmd-menu-item item 3 :tmd-menu-data
   make "tmd-menu-subitem item 4 :tmd-menu-data

   switch item 2 :tmd-menu-data
   [
      [  switch :tmd-menu-item
         [
            [  make "tmd-menu-temp ( filerequest "Load\ File\ \ -\  )
               ( intuition 6 :tg-screen )
               if emptyp :tmd-menu-temp [ ]
                  [ load :tmd-menu-temp ] ]
            [  make "tmd-menu-temp ( filerequest "Save\ File\ \ -\  )
               ( intuition 6 :tg-screen )
               if emptyp :tmd-menu-temp [ ]
               [  save  :tmd-menu-temp
                        remove-quick   se    gprop "startup-data "keepers
                                             [  s-item
                                                s-list
                                                tmd-menu-data
                                                tmd-menu-item
                                                tmd-menu-subitem
                                                tmd-menu-temp ]
                                       namelist ] ]
            [ edit ]
            [ edf [ ] ]
            [ endturtle type "? ]
            [ system 11 interrupt ]
            [ toplevel ]
            [ clean-quit ] ] ]

      [  switch :tmd-menu-item
         [
            [  make "tmd-menu-temp ( filerequest "Load\ Picture\ \ -\  )
               ( intuition 6 :tg-screen )
               if emptyp :tmd-menu-temp [ ]
               [  ( intuition 11 :tg-window )
                  wait 0.1
                  loadimage :tg-window :tmd-menu-temp ] ]

            [  make "tmd-menu-temp ( filerequest "Save\ Picture\ \ -\  )
               ( intuition 6 :tg-screen )
               if emptyp :tmd-menu-temp [ ]
               [  ( intuition 11 :tg-window )
                  wait 0.1
                  saveimage :tg-window :tmd-menu-temp
                  ( saveicon :tmd-menu-temp " [ FILETYPE=ilbm ] ) ] ]

            [ pattern :tmd-menu-subitem ]

            [ mouse-tool :tmd-menu-subitem ]

            [ action-tool :tmd-menu-subitem ]

            [ mode :tmd-menu-subitem ]

            [  switch :tmd-menu-subitem
               [  [ fs ]
                  [ ss ]
                  [ ts ]
                  [ palette-window ]
                  [ color-window ]
                  [ mouse-window ]
                  [ action-window ] ] ]

            [  ( turtle gprop "tg-data "modes :tmd-menu-subitem )
               type "? ]

            [  ( turtle - :tmd-menu-subitem 1 gprop "tg-data "depth )
               type "? ]
         ]
      ]
   ]
]


make "tg-mouse-demon [
   procedure [ [ ] [ ] [ :tmd-md :tmd-window :x :y :tmd-td ] ]
   dowhile [ make "tmd-md getmouse ] [ mousep ]
   make "tmd-window first :tmd-md
   make "x item 2 :tmd-md
   make "y item 3 :tmd-md
   cond
   [  [ = :tg-window :tmd-window ]
      [  make "tmd-td downp :tg-turtle
         pu
         run :tg-mouse-tool
         if :tmd-td [ pd ] [ ] ]
      [ = :tg-color-window :tmd-window ]
         [ click-color-window :x :y ]
      [ = :tg-mouse-window :tmd-window ]
         [ click-mouse-window :x :y ]
      [ = :tg-action-window :tmd-window ]
         [ click-action-window :x :y ]
   ]
]


make "tg-close-demon [
   procedure [ [ :tcd-window ] ]
   if memberp :tcd-window windowlist [ closewindow :tcd-window ] [ ] ]


; *********************************************************************
; *** Pen Color
; *********************************************************************


make "color-window [
   procedure [ [ ] [ ] [ :cw-sx :cw-sy :cw-c :cw-x :cw-y
                         :cw-x2 :cw-y2 :cw-i ] ]
   if memberp :tg-color-window windowlist
   [  ( intuition 11 :tg-color-window )
      stop ] [ ]

;  ***  AGA  ***
;                                            2  4  8  8 16 16 32 32
   make "cw-sx item gprop "tg-data "depth [ 96 48 24 24 12 12  6  6 ]
   make "cw-sy item gprop "tg-data "depth [ 32 32 32 16 16  8  8  4 ]
;                                            1  1  1  2  2  4  4  8

;   make "cw-sy item gprop "tg-data "depth [ 24 24 24 12 12  6  6  3 ]



   make "cw-x -   gprop "tg-data "width
               if < 600 gprop "tg-data "width [ 290 ] [ 200 ]


   make "cw-y - gprop "tg-data "height 73 ; *** AGA was 65
   make "tg-color-window ( openwindow  :tg-screen
                                       7
                                       [ Pen Color ]
                                       :cw-x :cw-y
                                       200 73 ) ; *** AGA was 65
   attach-menus :tg-color-window

   setpen :tg-color-window 1
   move :tg-color-window 17 19
   text :tg-color-window [ PU ]
   move :tg-color-window 55 19
   text :tg-color-window [ PD ]
   move :tg-color-window 85 19
   text :tg-color-window [ JAM1 ]
   move :tg-color-window 123 19
   text :tg-color-window [ JAM2 ]
   move :tg-color-window 161 19
   text :tg-color-window [ COMP ]
   move :tg-color-window 20 33
   text :tg-color-window [ FG ]
   move :tg-color-window 80 33
   text :tg-color-window [ BG ]
   move :tg-color-window 140 33
   text :tg-color-window [ AO ]

   setpen :tg-color-window ( pen :tg-window 0 )
   rectfill :tg-color-window 40 25 60 35
   setpen :tg-color-window ( pen :tg-window 1 )
   rectfill :tg-color-window 100 25 120 35
   setpen :tg-color-window ( pen :tg-window 2 )
   rectfill :tg-color-window 160 25 180 35

   make "cw-i 0
   make "cw-y 39
   make "cw-y2 + 38 :cw-sy
   while [ < :cw-y 70 ] ; *** AGA was 62
   [  make "cw-x 4
      make "cw-x2 + 3 :cw-sx
      while [ < :cw-x 192 ]
      [  setpen :tg-color-window :cw-i
         rectfill :tg-color-window :cw-x :cw-y :cw-x2 :cw-y2
         inc "cw-i
         make "cw-x + :cw-sx :cw-x
         make "cw-x2 + :cw-sx :cw-x2 ]
      make "cw-y + :cw-sy :cw-y
      make "cw-y2 + :cw-sy :cw-y2 ]

   setpen :tg-color-window 30
   drawbox :tg-color-window 5 11 36 10
   drawbox :tg-color-window 43 11 36 10
   drawbox :tg-color-window 81 11 36 10
   drawbox :tg-color-window 119 11 36 10
   drawbox :tg-color-window 157 11 36 10

   drawbox :tg-color-window 15 23 50 14
   drawbox :tg-color-window 75 23 50 14
   drawbox :tg-color-window 135 23 50 14

   setpen :tg-color-window 31
   drawbox :tg-color-window + 5 if downp :tg-turtle [ 38 ] [ 0 ] 11 36 10
   drawbox :tg-color-window + 43 * 38 gprop "tg-data "drawmode 11 36 10

   make "tg-color-pen 0
   color-pen-box 0
]


make "color-pen-box [
   procedure [ [ :cpb-c ] [ ] [ :cpb-x ] ]
   setpen :tg-color-window 30
   make "cpb-x + 15 * 60 :tg-color-pen
   drawbox :tg-color-window :cpb-x 23 50 14
   setpen :tg-color-window 31
   make "cpb-x + 15 * 60 :cpb-c
   drawbox :tg-color-window :cpb-x 23 50 14
   make "tg-color-pen :cpb-c ]


make "click-color-window [
   procedure [ [ :ccw-x :ccw-y ] [ ] [ :ccw-c ] ]
   cond
   [  [ >>= 24 36 :ccw-y ]
      [  cond
         [  [ >>= 15 65 :ccw-x ] [ color-pen-box 0 ]
            [ >>= 75 125 :ccw-x ] [ color-pen-box 1 ]
            [ >>= 135 185 :ccw-x ] [ color-pen-box 2 ] ] ]
;           ***    62 AGA ***    
      [ and >>= 39 70 :ccw-y >>= 4 195 :ccw-x ]
      [  make "ccw-c readpixel :tg-color-window :ccw-x :ccw-y
         ( setpen :tg-window :ccw-c :tg-color-pen )
         if = 2 :tg-color-pen [ ] [ settpn :ccw-c :tg-color-pen ]
         setpen :tg-color-window :ccw-c
         switch + 1 :tg-color-pen
         [  [ rectfill :tg-color-window 40 25 60 35 ]
            [ rectfill :tg-color-window 100 25 120 35 ]
            [ rectfill :tg-color-window 160 25 180 35 ] ] ]
      [ >>= 11 21 :ccw-y ]
      [  cond
         [  [ >>= 5 41 :ccw-x ] [ mode 1 ]
            [ >>= 43 79 :ccw-x ] [ mode 2 ]
            [ >>= 81 117 :ccw-x ] [ mode 3 ]
            [ >>= 119 155 :ccw-x ] [ mode 4 ]
            [ >>= 157 193 :ccw-x ] [ mode 5 ] ] ] ] ]


make "mode [
   procedure [ [ :m-item ] [ ] [ :m-x ] ]
   if = :m-item 1
   [  pu
      movechecks 2 6 2 1
      if memberp :tg-color-window windowlist
      [  setpen :tg-color-window 30
         drawbox :tg-color-window 43 11 36 10
         setpen :tg-color-window 31
         drawbox :tg-color-window 5 11 36 10 ] [ ]
      stop ] [ ]
   if = :m-item 2
   [  pd
      movechecks 2 6 1 2
      if memberp :tg-color-window windowlist
      [  setpen :tg-color-window 30
         drawbox :tg-color-window 5 11 36 10
         setpen :tg-color-window 31
         drawbox :tg-color-window 43 11 36 10 ] [ ]
      stop ] [ ]
   if memberp :tg-color-window windowlist
   [  setpen :tg-color-window 30
      make "m-x + 43 * 38 gprop "tg-data "drawmode 
      drawbox :tg-color-window :m-x 11 36 10
      setpen :tg-color-window 31
      make "m-x + -33 * 38 :m-item 
      drawbox :tg-color-window :m-x 11 36 10 ] [ ]
   settdm - :m-item 3
   setdrmode :tg-window - :m-item 3
   movechecks 2 6 + 2 gprop "tg-data "drawmode :m-item
   pprop "tg-data "drawmode - :m-item 2 ]


; *********************************************************************
; *** Mouse Tools
; *********************************************************************


make "mouse-window [
   procedure [ [ ] [ ] [ :mw-tool-names :mw-sy :mw-c :mw-x :mw-y :mw-i ] ]
   if memberp :tg-mouse-window windowlist
   [  ( intuition 11 :tg-mouse-window )
      stop ] [ ]
   make "mw-tool-names gprop "tg-data "mouse-tool-names
   make "mw-c count :mw-tool-names
   make "mw-sy + 17 * 10 :mw-c
   make "mw-x - gprop "tg-data "width 88
   make "mw-y - gprop "tg-data "height :mw-sy
   make "tg-mouse-window ( openwindow  :tg-screen
                                       7
                                       [ Mouse ]
                                       :mw-x :mw-y
                                       88 :mw-sy )
   attach-menus :tg-mouse-window

   setpen :tg-mouse-window 1
   make "mw-i 20
   repeat :mw-c
   [  move :tg-mouse-window 12 :mw-i
      text :tg-mouse-window first :mw-tool-names
      make "mw-tool-names bf :mw-tool-names
      make "mw-i + 10 :mw-i ]

   setpen :tg-mouse-window 30
   make "mw-i 12
   repeat :mw-c
   [  drawbox :tg-mouse-window 7 :mw-i 73 10
      make "mw-i + 10 :mw-i ]

   setpen :tg-mouse-window 31
   drawbox     :tg-mouse-window
               7
               + 2 * 10 gprop "tg-data "mouse-tool-number
               73
               10 ]


make "click-mouse-window [
   procedure [ [ :cmw-x :cmw-y ] [ ] [ :cmw-tc :cmw-tn ] ]
   make "cmw-tc count gprop "tg-data "mouse-tools
   make "cmw-tn int / - :cmw-y 4 10
   if > :cmw-tn :cmw-tc
   [  make "cmw-tn :cmw-tc ]
   [  if < :cmw-tn 1 [ make "cmw-tn 1 ] [ ] ]
   mouse-tool :cmw-tn ]


make "mouse-tool [
   procedure [ [ :mt-item ] ]
   if memberp :tg-mouse-window windowlist
   [  setpen :tg-mouse-window 30
      drawbox :tg-mouse-window 7 + 2 * 10 gprop "tg-data "mouse-tool-number 73 10
      setpen :tg-mouse-window 31
      drawbox :tg-mouse-window 7 + 2 * 10 :mt-item 73 10 ] [ ]
   movechecks 2 4 gprop "tg-data "mouse-tool-number :mt-item
   pprop "tg-data "mouse-tool-number :mt-item
   make "tg-mouse-tool item :mt-item gprop "tg-data "mouse-tools ]


make "addmouse [
   procedure [ [ :am-tool-name :am-tool ] [ ]
               [ :am-tool-names :am-tools :am-open ] ]
   make "am-tool-names gprop "tg-data "mouse-tool-names
   make "am-tools gprop "tg-data "mouse-tools
   if memberp :am-tool-name :am-tool-names [ ]
   [  make "am-open false
      if namep "tg-mouse-window
      [  if memberp :tg-mouse-window windowlist
         [  make "am-open true
            closewindow :tg-mouse-window ] [ ] ] [ ]
      pprop "tg-data "mouse-tool-names lput :am-tool-name :am-tool-names
      pprop "tg-data "mouse-tools lput :am-tool :am-tools
      repitem     14
                  :tg-menu
                  lput     se    [ ]
                                 word  "\ \  
                                       :am-tool-name
                           item 14 :tg-menu
      if memberp :tg-window windowlist [ reset-menus ] [ ]
      if :am-open [ mouse-window ] [ ] ] ]


make "mouse-tool-draw [
   procedure [ [ :x :y ] [ ] [ :mtd-md ] ]
   move :tg-window :x :y
   while [  make "mtd-md mouse :tg-window
            = 1 item 3 :mtd-md ]
   [  draw :tg-window first :mtd-md item 2 :mtd-md ]
   settpos wtpos :tg-turtle ]

addmouse "Draw [ mouse-tool-draw :x :y ]


make "mouse-tool-brush [
   procedure [ [ :mtb-size :x1 :y1 ] [ ] [ :x2 :y2 :x3 :y3 :mtb-md ] ]
   make "x2 :x1
   make "y2 :y1
   rectfill :tg-window  - :x2 :mtb-size - :y2 :mtb-size 
                        + :x2 :mtb-size + :y2 :mtb-size
   while [  make "mtb-md mouse :tg-window
            = 1 item 3 :mtb-md ]
   [  make "x3 item 1 :mtb-md
      make "y3 item 2 :mtb-md
      if and = :x2 :x3 = :y2 :y3 [ ]
      [  make "x2 :x3
         make "y2 :y3
         rectfill :tg-window  - :x2 :mtb-size - :y2 :mtb-size 
                              + :x2 :mtb-size + :y2 :mtb-size ] ]
   move :tg-window :x2 :y2
   settpos wtpos :tg-turtle ]

; addmouse "Brush\ 3 [ mouse-tool-brush 1 :x :y ]
; addmouse "Brush\ 5 [ mouse-tool-brush 2 :x :y ]
addmouse "Brush\ 7 [ mouse-tool-brush 3 :x :y ]


make "mouse-tool-linkline [
   procedure [ [ :x :y ] ]
   move :tg-window :x :y
   pd
   settpos wtpos :tg-turtle
   pu ]

addmouse "LinkLine [ mouse-tool-linkline :x :y ]


make "mouse-tool-oneline [
   procedure [ [ :x :y ] ]
   while-mouse-down :x :y
   [  setdrmode :tg-window 2 ]
   [  move :tg-window :x2 :y2
      draw :tg-window :x1 :y1 ]
   [  mode + 2 gprop "tg-data "drawmode
      settpos wtpos :tg-turtle
      move :tg-window :x2 :y2
      pd
      settpos wtpos :tg-turtle
      pu ] ]

addmouse "OneLine [ mouse-tool-oneline :x :y ]


make "mouse-tool-ellipse [
   procedure [ [ :x :y ] ]
   while-mouse-down :x :y
   [  setdrmode :tg-window 2 ]
   [  ellipse :tg-window :x1 :y1 abs - :x1 :x2 abs - :y1 :y2 ]
   [  mode + 2 gprop "tg-data "drawmode
      ellipse :tg-window :x1 :y1 abs - :x1 :x2 abs - :y1 :y2
      move :tg-window :x1 :y1
      settpos wtpos :tg-turtle ] ]

addmouse "Ellipse [ mouse-tool-ellipse :x :y ]


make "mouse-tool-block [
   procedure [ [ :x :y ] ]
   while-mouse-down :x :y
   [  setdrmode :tg-window 2 ]
   [  if > :x1 :x2 [ make "x1 :x2 ] [ ]
      if > :y1 :y2 [ make "y1 :y2 ] [ ]
      drawbox :tg-window :x1 :y1 - :x2 :x1 - :y2 :y1 ]
   [  setdrmode :tg-window 0
      rectfill :tg-window :x1 :y1 :x2 :y2
      mode + 2 gprop "tg-data "drawmode
      move :tg-window :x1 :y1
      settpos wtpos :tg-turtle ] ]

addmouse "Block [ mouse-tool-block :x :y ]


addmouse "Flood\ PC [   floodpc :tg-window :x :y
                        move :tg-window :x :y
                        settpos wtpos :tg-turtle ]

addmouse "Flood\ OL [   floodol :tg-window :x :y
                        move :tg-window :x :y
                        settpos wtpos :tg-turtle ]


make "mouse-tool-position [
   procedure [ [ :x :y ] ]
   while-mouse-down :x :y
   [  setdrmode :tg-window 2 ]
   [  move :tg-window :x2 :y2
      draw :tg-window :x1 :y1 ]
   [  settpos wtpos :tg-turtle
      make "x3 first wtpos :tg-turtle
      make "y3 first bf wtpos :tg-turtle
      move :tg-window :x2 :y2
      make "x3 - :x3 first wtpos :tg-turtle
      make "y3 - :y3 first bf wtpos :tg-turtle
      seth toward wtpos :tg-turtle :tg-turtle
      move :tg-window :x1 :y1
      make "size sqrt + * :x3 :x3 * :y3 :y3
      mode + 2 gprop "tg-data "drawmode ] ]

addmouse "Position [ mouse-tool-position :x :y ]


make "set-record [
   procedure [ [ :sr-rec ] ]
   pprop "tg-data "mouse-record :sr-rec ]

make "mouse-tool-record [
   procedure [ [ :x1 :y1 ] [ ] [ :mtr-rec :x2 :y2 :x3 :y3 :mtr-md ] ]
   make "mtr-rec fput :size :mtr-rec
   make "mtr-rec fput heading :tg-turtle :mtr-rec
   make "mtr-rec fput wtpos :tg-turtle :mtr-rec
   move :tg-window :x1 :y1
   make "mtr-rec fput wtpos :tg-turtle :mtr-rec
   make "x2 :x1
   make "y2 :y1
   while [  make "mtr-md mouse :tg-window
            = 1 item 3 :mtr-md ]
   [  make "x3 item 1 :mtr-md
      make "y3 item 2 :mtr-md
      if and = :x2 :x3 = :y2 :y3 [ ]
      [  make "x2 :x3
         make "y2 :y3
         draw :tg-window :x2 :y2
         make "mtr-rec fput wtpos :tg-turtle :mtr-rec ] ]
   move :tg-window first twpos :tg-turtle item 2 twpos :tg-turtle
   set-record :mtr-rec ]

addmouse "Record [ mouse-tool-record :x :y ]


make "while-mouse-down [
   procedure [ [ :x1 :y1 :wmd-prep :wmd-rough :wmd-fine ] [ ]
               [ :x2 :y2 :x3 :y3 :wmd-md ] ]
   run :wmd-prep
   make "x2 :x1
   make "y2 :y1
   run :wmd-rough
   while [  make "wmd-md mouse :tg-window
            = 1 item 3 :wmd-md ]
   [  make "x3 item 1 :wmd-md
      make "y3 item 2 :wmd-md
      if and = :x2 :x3 = :y2 :y3 [ ]
      [  run :wmd-rough
         make "x2 :x3
         make "y2 :y3
         run :wmd-rough ] ]
   run :wmd-rough
   run :wmd-fine ]


; *********************************************************************
; *** Action Tools
; *********************************************************************


make "action-window [
   procedure [ [ ] [ ] [ :cw-tool-names :cw-sy :cw-c :cw-x :cw-y :cw-i ] ]
   if memberp :tg-action-window windowlist
   [  ( intuition 11 :tg-action-window )
      stop ] [ ]
   make "cw-tool-names gprop "tg-data "action-tool-names
   make "cw-c count :cw-tool-names
   make "cw-sy + 17 * 10 :cw-c
   make "cw-x - gprop "tg-data "width 88
   make "cw-y ( -    gprop "tg-data "height
                     :cw-sy
                     if <= 400 gprop "tg-data "height 
                     [  + 19 * 10 count gprop "tg-data "mouse-tool-names ]
                     [ 0 ] )
   make "tg-action-window ( openwindow   :tg-screen
                                          7
                                          [ Action ]
                                          :cw-x :cw-y
                                          88 :cw-sy )
   attach-menus :tg-action-window

   setpen :tg-action-window 1
   make "cw-i 20
   repeat :cw-c
   [  move :tg-action-window 12 :cw-i
      text :tg-action-window first :cw-tool-names
      make "cw-tool-names bf :cw-tool-names
      make "cw-i + 10 :cw-i ]

   setpen :tg-action-window 30
   make "cw-i 12
   repeat :cw-c
   [  drawbox :tg-action-window 7 :cw-i 73 10
      make "cw-i + 10 :cw-i ] ]


make "click-action-window [
   procedure [ [ :caw-x :caw-y ] [ ]
               [ :caw-md :caw-tools :caw-tc :caw-tn
                 :caw-hit :caw-hit2 :caw-yn ] ]
   make "caw-tools gprop "tg-data "action-tools
   make "caw-tc count :caw-tools
   make "caw-tn int / - :caw-y 4 10
   if ( and >>= 1 :caw-tc :caw-tn >> 7 81 :caw-x )
   [  setpen :tg-action-window 31
      drawbox :tg-action-window 7 + 2 * 10 :caw-tn 73 10
      make "caw-hit true
      make "caw-hit2 true
      while [  make "caw-md mouse :tg-action-window
               = 1 item 3 :caw-md ]
      [  make "caw-x first :caw-md
         make "caw-yn int / - item 2 :caw-md 4 10
         make "caw-hit and = :caw-yn :caw-tn >> 7 81 :caw-x
         if = :caw-hit :caw-hit2 [ ]
         [  setpen :tg-action-window if :caw-hit [ 31 ] [ 30 ]
            drawbox :tg-action-window 7 + 2 * 10 :caw-tn 73 10
            make "caw-hit2 :caw-hit ] ]
      if :caw-hit [ switch :caw-tn :caw-tools ] [ ]
      setpen :tg-action-window 30
      drawbox :tg-action-window 7 + 2 * 10 :caw-tn 73 10 ] [ ] ]


make "action-tool [
   procedure [ [ :at-item ] ]
   switch :at-item gprop "tg-data "action-tools ]


make "addaction [
   procedure [ [ :aa-tool-name :aa-tool ] [ ]
               [ :aa-tool-names :aa-tools :aa-open ] ]
   make "aa-tool-names gprop "tg-data "action-tool-names
   make "aa-tools gprop "tg-data "action-tools
   if memberp :aa-tool-name :aa-tool-names [ ]
   [  make "aa-open false
      if namep "tg-action-window
      [  if memberp :tg-action-window windowlist
         [  make "aa-open true
            closewindow :tg-action-window ] [ ] ] [ ]
      pprop "tg-data "action-tool-names lput :aa-tool-name :aa-tool-names
      pprop "tg-data "action-tools lput :aa-tool :aa-tools
      repitem     15
                  :tg-menu
                  lput     se    [ ]
                                 word  "\ 
                                       :aa-tool-name
                           item 15 :tg-menu
      if memberp :tg-window windowlist [ reset-menus ] [ ]
      if :aa-open [ action-window ] [ ] ] ]

addaction "Home [ home ]
addaction "Clean [ clean ]
addaction "Clear [ home clean ]

addaction "HogMem [
   if emptyp gprop "tg-data "unhogmem
      [ pprop "tg-data "unhogmem system 1 ] [ ]
   ( system 2 gprop "tg-data "hogmem )
   ( recycle 1 ) ]

addaction "UnHogMem [
   if emptyp gprop "tg-data "unhogmem [ ]
   [  ( system 2 gprop "tg-data "unhogmem )
      pprop "tg-data "unhogmem [ ]
      recycle
      ( recycle 1 ) ] ]

addaction "Recycle [ ( recycle 1 ) ]


make "playback [
   procedure [ [ :pb-size :pb-rec ] [ ]
               [  :pb-scale :pb-rh :pb-rs :pb-down
                  :pb-sin :pb-cos :pb-tx :pb-ty
                  :pb-x :pb-y :pb-fx :pb-fy :pb-ep :pb-t ] ]
   if > 4 count :pb-rec [ stop ] [ ]
   make "pb-down downp :tg-turtle
   pu
   fd :pb-size
   make "pb-ep tpos :tg-turtle
   bk :pb-size
   make "pb-rec reverse :pb-rec
   make "pb-scale / :pb-size first :pb-rec
   make "pb-rec bf :pb-rec
   make "pb-sin sin - heading :tg-turtle first :pb-rec
   make "pb-cos cos - heading :tg-turtle first :pb-rec
   make "pb-rec bf :pb-rec
   make "pb-fx first first :pb-rec
   make "pb-fy item 2 first :pb-rec
   make "pb-x first tpos :tg-turtle
   make "pb-y first bf tpos :tg-turtle
   make "pb-rec bf :pb-rec
   make "pb-t first :pb-rec
   make "pb-tx - first :pb-t :pb-fx
   make "pb-ty - item 2 :pb-t :pb-fy
   settpos list   +  :pb-x
                     *  :pb-scale
                        +  * :pb-tx :pb-cos
                           * :pb-ty :pb-sin
                  +  :pb-y
                     *  :pb-scale
                        +  * :pb-ty :pb-cos
                           * +- :pb-tx :pb-sin
   make "pb-rec bf :pb-rec
   pd
   while [ not emptyp :pb-rec ]
   [  make "pb-t first :pb-rec
      make "pb-tx - first :pb-t :pb-fx
      make "pb-ty - item 2 :pb-t :pb-fy
      settpos list   +  :pb-x
                        *  :pb-scale
                           +  * :pb-tx :pb-cos
                              * :pb-ty :pb-sin
                     +  :pb-y
                        *  :pb-scale
                           +  * :pb-ty :pb-cos
                              * +- :pb-tx :pb-sin
      make "pb-rec bf :pb-rec ]
   pu
   settpos :pb-ep
   if :pb-down [ pd ] [ ] ]


make "record [
   procedure [ ]
   output gprop "tg-data "mouse-record ]

addaction "PlayBack [ playback :size record ]

addaction "MarkPos [ fd :size bk :size ]


addaction "Text [
   pr [ Enter Text ]
   type ">>
   ( intuition 12 @0 )
   text :tg-window rl ]


make "poly [
   procedure [ [ :p-size :p-sides ] [ ] [ :a ] ]
   make "a / 360 :p-sides
   repeat :p-sides [ fd :p-size rt :a ] ]

make "circle [
   procedure [ [ :c-size ] [ ] ]
   if downp :tg-turtle
   [  pu
      fd :c-size
      rt 91
      pd
      poly * :c-size 0.034906785 180
      pu
      lt 91
      bk :c-size
      pd ] [ ] ]

addaction "Circle [ circle :size ]


; addaction "TriAngle [ poly :size 3 ]
; addaction "Square [ poly :size 4 ]
; addaction "Pentagon [ poly :size 5 ]
; addaction "Hexagon [ poly :size 6 ]

addaction "Star\ 5 [ repeat 5 [ fd :size rt 144 ] ]


; *********************************************************************
; *** Palette Tool
; *********************************************************************


make "palette-window [
   procedure [ ]
   if ( palettep :tg-palette-window )
   [  ( intuition 11 :tg-palette-window ) ]
   [  make "tg-palette-window openpalette true :tg-screen
      attach-menus :tg-palette-window ] ]


; *********************************************************************
; *** Subs
; *********************************************************************


make "pattern [
   procedure [ [ :p-pn ] [ ] [ :p-pat ] ]
   make "p-pat item :p-pn [
         xxxxxxxxxxxxxxxx
         xxxxxxxx--------
         xxxx----xxxx----
         xx--xx--xx--xx--
         x-x-x-x-x-x-x-x-
         x---x---x---x---
         x-------x-------
         -xxx-xxx-xxx-xxx
         -xxxxxxx-xxxxxxx
         x---------------
         xx--------------
         xxxx------------
         xxxxxxxxxxxx----
         -------xxx---xxx
         xxxxxxx---xxx--- ]
   settlp :p-pat
   setlinept :tg-window :p-pat
   movechecks 2 3 gprop "tg-data "pattern :p-pn
   pprop "tg-data "pattern :p-pn ]


make "setghosts [
   procedure [ [ :sg-window ] ]
   if or = 1 gprop "tg-data "modes
         = 3 gprop "tg-data "modes
   [  ( intuition 3 :sg-window 2 8 5 )
      ( intuition 3 :sg-window 2 8 6 ) ] [ ]
   if >= gprop "tg-data "depth 5
   [  ( intuition 3 :sg-window 2 9 2 )
      ( intuition 3 :sg-window 2 9 4 ) ] [ ] ]


;  ***  added to disable "setghosts" for AGA  ***
make "setghosts [
   procedure [ [ :sg-window ] ] ]


make "setchecks [
   procedure [ [ :sc-window ] ]
   ( intuition 13 :sc-window 2 3 gprop "tg-data "pattern )
   ( intuition 13 :sc-window 2 6 if downp :tg-turtle [ 2 ] [ 1 ] )
   ( intuition 13 :sc-window 2 6 + 2 gprop "tg-data "drawmode )
   ( intuition 13 :sc-window 2 4 gprop "tg-data "mouse-tool-number )
   ( intuition 13 :sc-window 2 8 gprop "tg-data "depth )
   ( intuition 13 :sc-window 2 9 + 1 gprop "tg-data "modes ) ]


make "reset-menus [
   procedure [ ]
   attach-menus @0
   attach-menus :tg-window
   attach-menus :tg-color-window
   attach-menus :tg-palette-window
   attach-menus :tg-mouse-window
   attach-menus :tg-action-window ]


make "attach-menus [
   procedure [ [ :am-window ] ]
   if ( or  memberp :am-window windowlist
            = @0 :am-window ( palettep :am-window ) )
   [  setmenu :am-window :tg-menu
      setchecks :am-window
      setghosts :am-window ] [ ] ]


make "movechecks [
   procedure [ [ :mc-m :mc-i :mc-fs :mc-ts ] ]
   movecheck @0                  :mc-m :mc-i :mc-fs :mc-ts
   movecheck :tg-window          :mc-m :mc-i :mc-fs :mc-ts
   movecheck :tg-color-window    :mc-m :mc-i :mc-fs :mc-ts
   movecheck :tg-palette-window  :mc-m :mc-i :mc-fs :mc-ts
   movecheck :tg-mouse-window    :mc-m :mc-i :mc-fs :mc-ts
   movecheck :tg-action-window   :mc-m :mc-i :mc-fs :mc-ts ]


make "movecheck [
   procedure [ [ :mc-window :mc-m :mc-i :mc-fs :mc-ts ] ]
   if ( or    memberp :mc-window windowlist
              = @0 :mc-window ( palettep :mc-window ) )
   [  ( intuition 14 :mc-window :mc-m :mc-i :mc-fs )
      ( intuition 13 :mc-window :mc-m :mc-i :mc-ts ) ] [ ] ]


make "drawbox [
   procedure [ [ :db-window :db-le :db-te :db-w :db-h ] ]
   move :db-window :db-le :db-te
   draw :db-window + :db-le :db-w :db-te
   draw :db-window + :db-le :db-w + :db-te :db-h
   draw :db-window :db-le + :db-te :db-h
   draw :db-window :db-le :db-te ]


; *********************************************************************
; *** Screen and Windows
; *********************************************************************

;  clear text

make "ct [ procedure [ ] cleartext ]

;  clear screen

make "cs [ procedure [ ] home clean ]

;  full screen

make "fs [ procedure [ ] ( intuition 11 :tg-window ) ]

;  text screen

make "ts [ procedure [ ]
   ( intuition 12 @0 )
   ( intuition 11 @0 )
   ( intuition 2 @0 0 0 )
   wait 0.1
   ( intuition 8 @0 gprop "tg-data "width gprop "tg-data "height ) ]


;  split screen

make "ss [
   procedure [ [ ] [ ] [ :ss-w :ss-h :ss-sx :ss-sy ] ]
   make "ss-w gprop "tg-data "width
   make "ss-h gprop "tg-data "height
   make "ss-sx if <= 640 :ss-w [ - :ss-w 292 ] [ :ss-w ]
   make "ss-sy if <= 400 :ss-h [ 54 ] [ 46 ]
   ( intuition 12 @0 )
   ( intuition 11 @0 )
   ( intuition 10 :tg-window )
   ( intuition 8 @0 :ss-sx :ss-sy )
   wait 0.1
   ( intuition 2 @0 0 - :ss-h :ss-sy ) ]


; *********************************************************************

bury :turtle-names