turtle.f

   1 \\r
   2 \ TURTLE.F\r
   3 \ Turtle graphics package for hForth\r
   4 \\r
   5 \ English and Korean sources are provided (See [IF] ... [ELSE] ... [THEN]).\r
   6 \\r
   7 \ ETURTLE.EXE and HTURTLE.EXE is built from HF86EXE.EXE by loading Forth\r
   8 \   sources in the following order.\r
   9 \\r
  10 \       << OPTIONAL.F\r
  11 \       << ASM8086.F\r
  12 \       << COREEXT.F\r
  13 \       << MSDOS.F\r
  14 \       BL PARSE MULTI.F    INCLUDED\r
  15 \       BL PARSE HIOMULT2.F INCLUDED\r
  16 \       BL PARSE TURTLE.F   INCLUDED\r
  17 \       SAVE-SYSTEM-AS ETURTLE.EXE\r
  18 \       ( or SAVE-SYSTEM-AS HTURTLE.EXE )\r
  19 \\r
  20 \ 1996. 2. 21.\r
  21 \ Wonyong Koh\r
  22 \r
  23 BASE @\r
  24 GET-ORDER  GET-CURRENT\r
  25 WORDLIST WORDLIST-NAME GRAPHIC-WORDLIST\r
  26 �e\8bi���\89\9db-WORDLIST GRAPHIC-WORDLIST GET-ORDER 2 + SET-ORDER\r
  27 \r
  28 MARKER ~TURTLE\r
  29 \r
  30 DECIMAL\r
  31 CREATE sin16384\r
  32      0 ,    286 ,    572 ,    857 ,   1143 ,   1428 ,   1713 ,   1997 ,   2280 ,   2563 ,\r
  33   2845 ,   3126 ,   3406 ,   3686 ,   3964 ,   4240 ,   4516 ,   4790 ,   5063 ,   5334 ,\r
  34   5604 ,   5872 ,   6138 ,   6402 ,   6664 ,   6924 ,   7182 ,   7438 ,   7692 ,   7943 ,\r
  35   8192 ,   8438 ,   8682 ,   8923 ,   9162 ,   9397 ,   9630 ,   9860 ,  10087 ,  10311 ,\r
  36  10531 ,  10749 ,  10963 ,  11174 ,  11381 ,  11585 ,  11786 ,  11982 ,  12176 ,  12365 ,\r
  37  12551 ,  12733 ,  12911 ,  13085 ,  13255 ,  13421 ,  13583 ,  13741 ,  13894 ,  14044 ,\r
  38  14189 ,  14330 ,  14466 ,  14598 ,  14726 ,  14849 ,  14968 ,  15082 ,  15191 ,  15296 ,\r
  39  15396 ,  15491 ,  15582 ,  15668 ,  15749 ,  15826 ,  15897 ,  15964 ,  16026 ,  16083 ,\r
  40  16135 ,  16182 ,  16225 ,  16262 ,  16294 ,  16322 ,  16344 ,  16362 ,  16374 ,  16382 ,\r
  41  16384 ,  16382 ,  16374 ,  16362 ,  16344 ,  16322 ,  16294 ,  16262 ,  16225 ,  16182 ,\r
  42  16135 ,  16083 ,  16026 ,  15964 ,  15897 ,  15826 ,  15749 ,  15668 ,  15582 ,  15491 ,\r
  43  15396 ,  15296 ,  15191 ,  15082 ,  14968 ,  14849 ,  14726 ,  14598 ,  14466 ,  14330 ,\r
  44  14189 ,  14044 ,  13894 ,  13741 ,  13583 ,  13421 ,  13255 ,  13085 ,  12911 ,  12733 ,\r
  45  12551 ,  12365 ,  12176 ,  11982 ,  11786 ,  11585 ,  11381 ,  11174 ,  10963 ,  10749 ,\r
  46  10531 ,  10311 ,  10087 ,   9860 ,   9630 ,   9397 ,   9162 ,   8923 ,   8682 ,   8438 ,\r
  47   8192 ,   7943 ,   7692 ,   7438 ,   7182 ,   6924 ,   6664 ,   6402 ,   6138 ,   5872 ,\r
  48   5604 ,   5334 ,   5063 ,   4790 ,   4516 ,   4240 ,   3964 ,   3686 ,   3406 ,   3126 ,\r
  49   2845 ,   2563 ,   2280 ,   1997 ,   1713 ,   1428 ,   1143 ,    857 ,    572 ,    286 ,\r
  50      0 ,   -286 ,   -572 ,   -857 ,  -1143 ,  -1428 ,  -1713 ,  -1997 ,  -2280 ,  -2563 ,\r
  51  -2845 ,  -3126 ,  -3406 ,  -3686 ,  -3964 ,  -4240 ,  -4516 ,  -4790 ,  -5063 ,  -5334 ,\r
  52  -5604 ,  -5872 ,  -6138 ,  -6402 ,  -6664 ,  -6924 ,  -7182 ,  -7438 ,  -7692 ,  -7943 ,\r
  53  -8192 ,  -8438 ,  -8682 ,  -8923 ,  -9162 ,  -9397 ,  -9630 ,  -9860 , -10087 , -10311 ,\r
  54 -10531 , -10749 , -10963 , -11174 , -11381 , -11585 , -11786 , -11982 , -12176 , -12365 ,\r
  55 -12551 , -12733 , -12911 , -13085 , -13255 , -13421 , -13583 , -13741 , -13894 , -14044 ,\r
  56 -14189 , -14330 , -14466 , -14598 , -14726 , -14849 , -14968 , -15082 , -15191 , -15296 ,\r
  57 -15396 , -15491 , -15582 , -15668 , -15749 , -15826 , -15897 , -15964 , -16026 , -16083 ,\r
  58 -16135 , -16182 , -16225 , -16262 , -16294 , -16322 , -16344 , -16362 , -16374 , -16382 ,\r
  59 -16384 , -16382 , -16374 , -16362 , -16344 , -16322 , -16294 , -16262 , -16225 , -16182 ,\r
  60 -16135 , -16083 , -16026 , -15964 , -15897 , -15826 , -15749 , -15668 , -15582 , -15491 ,\r
  61 -15396 , -15296 , -15191 , -15082 , -14968 , -14849 , -14726 , -14598 , -14466 , -14330 ,\r
  62 -14189 , -14044 , -13894 , -13741 , -13583 , -13421 , -13255 , -13085 , -12911 , -12733 ,\r
  63 -12551 , -12365 , -12176 , -11982 , -11786 , -11585 , -11381 , -11174 , -10963 , -10749 ,\r
  64 -10531 , -10311 , -10087 ,  -9860 ,  -9630 ,  -9397 ,  -9162 ,  -8923 ,  -8682 ,  -8438 ,\r
  65  -8192 ,  -7943 ,  -7692 ,  -7438 ,  -7182 ,  -6924 ,  -6664 ,  -6402 ,  -6138 ,  -5872 ,\r
  66  -5604 ,  -5334 ,  -5063 ,  -4790 ,  -4516 ,  -4240 ,  -3964 ,  -3686 ,  -3406 ,  -3126 ,\r
  67  -2845 ,  -2563 ,  -2280 ,  -1997 ,  -1713 ,  -1428 ,  -1143 ,   -857 ,   -572 ,   -286 ,\r
  68     -0 ,    286 ,    572 ,    857 ,   1143 ,   1428 ,   1713 ,   1997 ,   2280 ,   2563 ,\r
  69   2845 ,   3126 ,   3406 ,   3686 ,   3964 ,   4240 ,   4516 ,   4790 ,   5063 ,   5334 ,\r
  70   5604 ,   5872 ,   6138 ,   6402 ,   6664 ,   6924 ,   7182 ,   7438 ,   7692 ,   7943 ,\r
  71   8192 ,   8438 ,   8682 ,   8923 ,   9162 ,   9397 ,   9630 ,   9860 ,  10087 ,  10311 ,\r
  72  10531 ,  10749 ,  10963 ,  11174 ,  11381 ,  11585 ,  11786 ,  11982 ,  12176 ,  12365 ,\r
  73  12551 ,  12733 ,  12911 ,  13085 ,  13255 ,  13421 ,  13583 ,  13741 ,  13894 ,  14044 ,\r
  74  14189 ,  14330 ,  14466 ,  14598 ,  14726 ,  14849 ,  14968 ,  15082 ,  15191 ,  15296 ,\r
  75  15396 ,  15491 ,  15582 ,  15668 ,  15749 ,  15826 ,  15897 ,  15964 ,  16026 ,  16083 ,\r
  76  16135 ,  16182 ,  16225 ,  16262 ,  16294 ,  16322 ,  16344 ,  16362 ,  16374 ,  16382 ,\r
  77 \r
  78 CODE sin* ( length theta -- length*sin[theta] )\r
  79 \ : sin*   CELLS sin16384 + @ M* 16384 SM/REM NIP ;\r
  80     BX 1 SHL,\r
  81     sin16384 [BX] BX MOV,\r
  82     AX POP,\r
  83     BX IMUL,\r
  84     BX BX XOR,\r
  85     AX 1 SHL,\r
  86     DX 1 RCL,\r
  87     AX 1 SHL,\r
  88     DX 1 RCL,\r
  89     DX BX ADC,\r
  90     NEXT,\r
  91 END-CODE\r
  92 \r
  93 CODE cos* ( length theta -- length*cos[theta] )\r
  94 \ : cos*   90 + CELLS sin16384 + @ M* 16384 SM/REM NIP ;\r
  95     90 # BX ADD,\r
  96     BX 1 SHL,\r
  97     sin16384 [BX] BX MOV,\r
  98     AX POP,\r
  99     BX IMUL,\r
 100     BX BX XOR,\r
 101     AX 1 SHL,\r
 102     DX 1 RCL,\r
 103     AX 1 SHL,\r
 104     DX 1 RCL,\r
 105     DX BX ADC,\r
 106     NEXT,\r
 107 END-CODE\r
 108 \r
 109 HEX\r
 110 \ : PLOT  ( x y -- )\r
 111 \     Y>SEG SWAP 8 /MOD SWAP >R           \ seg_addr x/8  R: x_mod_8\r
 112 \     2DUP LC@ R> CHARS XMASK + C@ OR ROT ROT LC! ;\r
 113 \r
 114 CODE PLOT  ( x y -- )\r
 115     BX 1 SHL,\r
 116     Y>SegTable ) BX ADD,\r
 117     0 [BX] ES MOV,\r
 118     BX POP,\r
 119     BX CX MOV,\r
 120     BX 1 SHR,\r
 121     BX 1 SHR,\r
 122     BX 1 SHR,\r
 123     ES: 0 [BX] AL MOV,\r
 124     1 # AH MOV,\r
 125     CL NOT,\r
 126     7 # CL AND,\r
 127     AH CL ROL,\r
 128     AH AL OR,\r
 129     ES: AL 0 [BX] MOV,\r
 130     BX POP,\r
 131     NEXT,\r
 132 END-CODE\r
 133 \r
 134 \ : 2ROT\r
 135 \     >R >R 2SWAP R> R> 2SWAP ;\r
 136 \\r
 137 \ : LINE  ( x1 y1 x2 y2--)\r
 138 \     2OVER 2OVER ROT - ABS >R - ABS R> MAX 2 <\r
 139 \     IF 2DROP PLOT EXIT THEN\r
 140 \     2OVER 2OVER ROT + 1+ 2/ >R + 1+ 2/ R>\r
 141 \     2DUP 2ROT RECURSE RECURSE ;\r
 142 \r
 143 VARIABLE Delta\r
 144 VARIABLE Delta/2\r
 145 \r
 146 \ y changing faster than x\r
 147 CODE steep640   \ on entry, ax = delta x, bx = delta y, cx=x1, dx=y1\r
 148     BX BP MOV,                  \ for counter\r
 149     BX 1 SHR,\r
 150     BX Delta/2 ) MOV,           \ halfy\r
 151     BX BX XOR,                  \ clear for cmp\r
 152 6 L:\r
 153     BX PUSH,\r
 154     CX PUSH,            \ x\r
 155     DX BX MOV,\r
 156     BX 1 SHL,\r
 157     Y>SegTable ) BX ADD,\r
 158     0 [BX] ES MOV,\r
 159     CX BX MOV,\r
 160     BX 1 SHR,\r
 161     BX 1 SHR,\r
 162     BX 1 SHR,\r
 163     ES: 0 [BX] AL MOV,\r
 164     1 # AH MOV,\r
 165     CL NOT,\r
 166     7 # CL AND,\r
 167     AH CL ROL,\r
 168     AH AL OR,\r
 169     ES: AL 0 [BX] MOV,\r
 170     CX POP,\r
 171     BX POP,\r
 172     DX INC,                     \ y is always increasing\r
 173     MAX-Y 16* # DX CMP,\r
 174     8 L# JL,\r
 175     DX DX XOR,\r
 176 8 L:\r
 177     Delta ) BX ADD,             \ = bx + delta_y\r
 178     Delta/2 ) BX CMP,           \ bx > halfy ?\r
 179     7 L# JLE,\r
 180     SI BX SUB,                  \ bx - delta_y\r
 181     DI CX ADD,                  \ inc or dec x\r
 182     MAX-X 8 * # CX SUB,\r
 183     7 L# JNS,\r
 184     MAX-X 8 * # CX ADD,\r
 185     7 L# JNS,\r
 186     MAX-X 8 * # CX ADD,\r
 187 7 L:\r
 188     BP DEC,\r
 189     6 L# JGE,\r
 190     BP POP,\r
 191     SI POP,\r
 192     BX POP,\r
 193     NEXT,\r
 194 END-CODE\r
 195 \r
 196 \ on exit, cx=x1, dx=y1, ax=x2, bx=y2\r
 197 CODE line640  ( x1 y1 x2 y2 -- )        \ writes to screen directly\r
 198     AX POP,\r
 199     DX POP,\r
 200     CX POP,\r
 201     SI PUSH,   ( used to hold direction)\r
 202     BP PUSH,   ( used as counter)\r
 203 \ see if we'll inc or dec x, y (draws in any direction)\r
 204     DX BX SUB,                  \ bx <- y2-y1 (delta y)\r
 205     2 L# JGE,\r
 206     BX DX ADD,                  \ dx <- y2\r
 207     BX NEG,                     \ abs(delta y)\r
 208     CX AX XCHG,\r
 209 2 L:\r
 210     BX SI MOV,                  \ delta_y(BX) to SI\r
 211     CX AX SUB,                  \ x2 - x1 = delta_x\r
 212     1 # DI MOV,                 \ di to increment x\r
 213     4 L# JGE,\r
 214     -1 # DI MOV,                \ di to decrement x\r
 215     AX NEG,                     \ abs(delta x)\r
 216 4 L:\r
 217     \ adjust x1(CX), y1(DX) in proper range\r
 218     AX PUSH,\r
 219     DX PUSH,\r
 220     CX AX MOV,\r
 221     CWD,\r
 222     MAX-X 8 * # BP MOV,\r
 223     BP IDIV,\r
 224     DX DX OR,\r
 225     1 L# JNS,\r
 226     BP DX ADD,\r
 227 1 L:\r
 228     DX CX MOV,\r
 229     DX POP,\r
 230     DX AX MOV,\r
 231     CWD,\r
 232     MAX-Y 16* # BP MOV,\r
 233     BP IDIV,\r
 234     DX DX OR,\r
 235     8 L# JNS,\r
 236     BP DX ADD,\r
 237 8 L:\r
 238     AX POP,\r
 239     AX Delta ) MOV,             \ abs(delta x)\r
 240     BX AX CMP,                  \ delta_x - delta_y\r
 241     5 L# JGE,\r
 242     ' steep640 # JMP,           \ y changes faster than x\r
 243 5 L:\r
 244 \ x changing faster than y\r
 245     AX BP MOV,                  \ for counter\r
 246     AX 1 SHR,\r
 247     AX Delta/2 ) MOV,           \ halfx\r
 248     BX BX XOR,                  \ clear for cmp\r
 249 6 L:\r
 250     BX PUSH,\r
 251     CX PUSH,            \ x\r
 252     DX BX MOV,\r
 253     BX 1 SHL,\r
 254     Y>SegTable ) BX ADD,\r
 255     0 [BX] ES MOV,\r
 256     CX BX MOV,\r
 257     BX 1 SHR,\r
 258     BX 1 SHR,\r
 259     BX 1 SHR,\r
 260     ES: 0 [BX] AL MOV,\r
 261     1 # AH MOV,\r
 262     CL NOT,\r
 263     7 # CL AND,\r
 264     AH CL ROL,\r
 265     AH AL OR,\r
 266     ES: AL 0 [BX] MOV,\r
 267     CX POP,\r
 268     BX POP,\r
 269     DI CX ADD,                  \ inc or dec x\r
 270     MAX-X 8 * # CX SUB,\r
 271     9 L# JNS,\r
 272     MAX-X 8 * # CX ADD,\r
 273     9 L# JNS,\r
 274     MAX-X 8 * # CX ADD,\r
 275 9 L:\r
 276     SI BX ADD,                  \ = bx + delta_y\r
 277     Delta/2 ) BX CMP,           \ bx > halfx ?\r
 278     7 L# JLE,\r
 279     Delta ) BX SUB,             \ bx - delta_x\r
 280     DX INC,                     \ y is always increasing\r
 281     MAX-Y 16* # DX CMP,\r
 282     7 L# JL,\r
 283     DX DX XOR,\r
 284 7 L:\r
 285     BP DEC,\r
 286     6 L# JGE,\r
 287     BP POP,\r
 288     SI POP,\r
 289     BX POP,\r
 290     NEXT,\r
 291 END-CODE\r
 292 \r
 293 \ y changing faster than x\r
 294 CODE xsteep640   \ on entry, ax = delta x, bx = delta y, cx=x1, dx=y1\r
 295     BX BP MOV,                  \ for counter\r
 296     BX 1 SHR,\r
 297     BX Delta/2 ) MOV,           \ halfy\r
 298     BX BX XOR,                  \ clear for cmp\r
 299 6 L:\r
 300     BX PUSH,\r
 301     CX PUSH,            \ x\r
 302     DX BX MOV,\r
 303     BX 1 SHL,\r
 304     Y>SegTable ) BX ADD,\r
 305     0 [BX] ES MOV,\r
 306     CX BX MOV,\r
 307     BX 1 SHR,\r
 308     BX 1 SHR,\r
 309     BX 1 SHR,\r
 310     ES: 0 [BX] AL MOV,\r
 311     1 # AH MOV,\r
 312     CL NOT,\r
 313     7 # CL AND,\r
 314     AH CL ROL,\r
 315     AH AL XOR,\r
 316     ES: AL 0 [BX] MOV,\r
 317     CX POP,\r
 318     BX POP,\r
 319     DX INC,                     \ y is always increasing\r
 320     MAX-Y 16* # DX CMP,\r
 321     8 L# JL,\r
 322     DX DX XOR,\r
 323 8 L:\r
 324     Delta ) BX ADD,             \ = bx + delta_y\r
 325     Delta/2 ) BX CMP,           \ bx > halfy ?\r
 326     7 L# JLE,\r
 327     SI BX SUB,                  \ bx - delta_y\r
 328     DI CX ADD,                  \ inc or dec x\r
 329     MAX-X 8 * # CX SUB,\r
 330     7 L# JNS,\r
 331     MAX-X 8 * # CX ADD,\r
 332     7 L# JNS,\r
 333     MAX-X 8 * # CX ADD,\r
 334 7 L:\r
 335     BP DEC,\r
 336     6 L# JGE,\r
 337     BP POP,\r
 338     SI POP,\r
 339     BX POP,\r
 340     NEXT,\r
 341 END-CODE\r
 342 \r
 343 \ on exit, cx=x1, dx=y1, ax=x2, bx=y2\r
 344 CODE xline640  ( x1 y1 x2 y2 -- )        \ writes to screen directly\r
 345     AX POP,\r
 346     DX POP,\r
 347     CX POP,\r
 348     SI PUSH,   ( used to hold direction)\r
 349     BP PUSH,   ( used as counter)\r
 350 \ see if we'll inc or dec x, y (draws in any direction)\r
 351     DX BX SUB,                  \ bx <- y2-y1 (delta y)\r
 352     2 L# JGE,\r
 353     BX DX ADD,                  \ dx <- y2\r
 354     BX NEG,                     \ abs(delta y)\r
 355     CX AX XCHG,\r
 356 2 L:\r
 357     BX SI MOV,                  \ delta_y(BX) to SI\r
 358     CX AX SUB,                  \ x2 - x1 = delta_x\r
 359     1 # DI MOV,                 \ di to increment x\r
 360     4 L# JGE,\r
 361     -1 # DI MOV,                \ di to decrement x\r
 362     AX NEG,                     \ abs(delta x)\r
 363 4 L:\r
 364     \ adjust x1(CX), y1(DX) in proper range\r
 365     MAX-X 8 * # CX SUB,\r
 366     1 L# JNS,\r
 367     MAX-X 8 * # CX ADD,\r
 368     1 L# JNS,\r
 369     MAX-X 8 * # CX ADD,\r
 370 1 L:\r
 371     MAX-Y 16* # DX SUB,\r
 372     8 L# JNS,\r
 373     MAX-Y 16* # DX ADD,\r
 374     8 L# JNS,\r
 375     MAX-Y 16* # DX ADD,\r
 376 8 L:\r
 377     AX Delta ) MOV,             \ abs(delta x)\r
 378     BX AX CMP,                  \ delta_x - delta_y\r
 379     5 L# JGE,\r
 380     ' xsteep640 # JMP,          \ y changes faster than x\r
 381 5 L:\r
 382 \ x changing faster than y\r
 383     AX BP MOV,                  \ for counter\r
 384     AX 1 SHR,\r
 385     AX Delta/2 ) MOV,           \ halfx\r
 386     BX BX XOR,                  \ clear for cmp\r
 387 6 L:\r
 388     BX PUSH,\r
 389     CX PUSH,            \ x\r
 390     DX BX MOV,\r
 391     BX 1 SHL,\r
 392     Y>SegTable ) BX ADD,\r
 393     0 [BX] ES MOV,\r
 394     CX BX MOV,\r
 395     BX 1 SHR,\r
 396     BX 1 SHR,\r
 397     BX 1 SHR,\r
 398     ES: 0 [BX] AL MOV,\r
 399     1 # AH MOV,\r
 400     CL NOT,\r
 401     7 # CL AND,\r
 402     AH CL ROL,\r
 403     AH AL XOR,\r
 404     ES: AL 0 [BX] MOV,\r
 405     CX POP,\r
 406     BX POP,\r
 407     DI CX ADD,                  \ inc or dec x\r
 408     MAX-X 8 * # CX SUB,\r
 409     9 L# JNS,\r
 410     MAX-X 8 * # CX ADD,\r
 411     9 L# JNS,\r
 412     MAX-X 8 * # CX ADD,\r
 413 9 L:\r
 414     SI BX ADD,                  \ = bx + delta_y\r
 415     Delta/2 ) BX CMP,           \ bx > halfx ?\r
 416     7 L# JLE,\r
 417     Delta ) BX SUB,             \ bx - delta_x\r
 418     DX INC,                     \ y is always increasing\r
 419     MAX-Y 16* # DX CMP,\r
 420     7 L# JL,\r
 421     DX DX XOR,\r
 422 7 L:\r
 423     BP DEC,\r
 424     6 L# JGE,\r
 425     BP POP,\r
 426     SI POP,\r
 427     BX POP,\r
 428     NEXT,\r
 429 END-CODE\r
 430 \r
 431 \ Get a 'Y' or 'N' key. Return TURE for 'Y', otherwise return FALSE.\r
 432 : Y/N?  ( -- f )\r
 433    TRUE                     \ leave TRUE flag\r
 434    BEGIN  KEY\r
 435       DUP  [CHAR] Y =\r
 436       OVER [CHAR] y = OR 0=\r
 437    WHILE\r
 438       DUP  [CHAR] N =\r
 439       OVER [CHAR] n = OR 0=\r
 440    WHILE DROP\r
 441    REPEAT   \ 'N' comes hear\r
 442       DROP FALSE SWAP\r
 443    THEN\r
 444             \ 'Y' comes hear\r
 445    DROP ;\r
 446 \r
 447 CR .( Will you use Turtle Graphics words in Korean? [Y/N] )\r
 448 Y/N? [IF]\r
 449 \r
 450 DECIMAL\r
 451 10 CONSTANT scale\r
 452 0 VALUE \90\81\9f��\95?\r
 453 VARIABLE �wз\r
 454 MAX-X 8 * 2/ VALUE xOffset\r
 455 MAX-Y 16 * 2/ VALUE yOffset\r
 456 VARIABLE xCoord  xOffset xCoord !\r
 457 VARIABLE yCoord  yOffset yCoord !\r
 458 \r
 459 : �\95\97i�� ( -- )     FALSE TO \90\81\9f��\95? ;\r
 460 : �\95\90\81\9da ( -- )     TRUE  TO \90\81\9f��\95? ;\r
 461 : �\89���e ( y -- )   MAX-Y SWAP - TO YTop ;\r
 462 : �����e ( -- )     PAGE ;\r
 463 \r
 464 : \9d�.\8ba�� ( x y -- )\r
 465     scale / yOffset SWAP -          \ x y1\r
 466     SWAP scale / xOffset + SWAP     \ x1 y1\r
 467     \90\81\9f��\95? IF 2DUP xCoord @ yCoord @ line640 THEN\r
 468     yCoord !  xCoord ! ;\r
 469 \r
 470 : \88�\82���a ( -- )\r
 471     xCoord @  8 �wз @ 270 + sin* +\r
 472     yCoord @  8 �wз @ 270 + cos* -\r
 473     2DUP xCoord @ yCoord @ xline640                 \ x1 y1\r
 474     xCoord @  16 �wз @ sin* +\r
 475     yCoord @  16 �wз @ cos* -                      \ x1 y1 x2 y2\r
 476     2SWAP 2OVER xline640                            \ x2 y2\r
 477     xCoord @  8 �wз @ 90 + sin* +\r
 478     yCoord @  8 �wз @ 90 + cos* -                  \ x2 y2 x3 y3\r
 479     2SWAP 2OVER xline640                            \ x3 y3\r
 480     xCoord @  yCoord @  xline640 ;\r
 481 \r
 482 : ���e���� ( -- )   YTop PAGE 0 OVER AT-XY TO YTop \88�\82���a ;\r
 483 \r
 484 HEX\r
 485 : \88{�e�i ( xt 'name2' -- )\r
 486     DUP xt>name ?DUP 0= IF -12 THROW THEN\r
 487     SWAP head, linkLast\r
 488     C@ DUP\r
 489     040 AND IF IMMEDIATE    THEN\r
 490     020 AND IF COMPILE-ONLY THEN ;\r
 491 \r
 492 DECIMAL\r
 493 ' IMMEDIATE  \88{�e�i  �a\9d�\r
 494 ' RECURSE    \88{�e�i  \96A�\89\9c�\r
 495 ' IF         \88{�e�i  �e\r
 496 ' ELSE       \88{�e�i  �a\93��e\r
 497 ' THEN       \88{�e�i  \9ca\r
 498 ' BEGIN      \88{�e�i  ���A�\81��\r
 499 ' UNTIL      \88{�e�i  \8ca��\r
 500 ' WHILE      \88{�e�i  \95��e\r
 501 ' REPEAT     \88{�e�i  \88�\97s�\81\r
 502 ' DO         \88{�e�i  �\91\r
 503 ' LOOP       \88{�e�i  \95��a\r
 504 ' I          \88{�e�i  \88a\r
 505 ' CONSTANT   \88{�e�i  \8a\88�e\88t\r
 506 ' VARIABLE   \88{�e�i  �\81\9fe\88t\r
 507 ' DUP        \88{�e�i  �A\8da\r
 508 ' OVER       \88{�e�i  \88�\90�\r
 509 ' DROP       \88{�e�i  ��\9da\r
 510 ' SWAP       \88{�e�i  �a\8e�\r
 511 ' ROT        \88{�e�i  \95�\9da\r
 512 ' >R         \88{�e�i  >\96A\r
 513 ' R>         \88{�e�i  \96A>\r
 514 ' R@         \88{�e�i  \96A@\r
 515 ' AND        \88{�e�i  \90{�q\8dA\r
 516 ' OR         \88{�e�i  \90{�a�\89\9c�\r
 517 ' XOR        \88{�e�i  \90{\98a\9d�\r
 518 ' MOD        \88{�e�i  \90a�ỡ\r
 519 ' CR         \88{�e�i  \94a�q�\89\r
 520 ' WORDS      \88{�e�i  �i�a\r
 521 ' .S         \88{�e�i  .\94ᣡ\r
 522 \r
 523 ' BYE        \88{�e�i  \8f{\r
 524 \r
 525 �\81\9fe\88t \88a\9d���á\r
 526 �\81\9fe\88t �A\9d���á\r
 527 \r
 528 : �A�a\9f�\9d�   ( -- )\r
 529         \88�\82���a\r
 530         0 �wз !\r
 531         0 \88a\9d���á !\r
 532         0 �A\9d���á !\r
 533         0 0 \9d�.\8ba��\r
 534         \88�\82���a ;\r
 535 \r
 536 : ���e����   ( -- )\r
 537         �\95\97i�� �A�a\9f�\9d� ���e���� �\95\90\81\9da ;\r
 538 \r
 539 : ��\88\85���e ( -- )    8 �\89���e  ���e���� ;\r
 540 : �����e   ( -- )    �����e    ���e���� ;\r
 541 \r
 542 : \95�.��\9fe��  ( \88b\95� -- )\r
 543         \88�\82���a\r
 544         �wз @ +\r
 545         �A\8da 0 < �e                  ( \88b\95�\88a 0��\94a �b�a�e)\r
 546                    ���A�\81�� 360 +    ( 0 ���w�� \96I \98\81\8ca�� 360�i \94��q)\r
 547                    �A\8da -1 > \8ca��\r
 548                  �a\93��e 360 \90a�ỡ   ( 0��\94a �a�e 360�a\9d� \90a\92\85 \90a�ỡ\9fi \90q\8b�)\r
 549                  \9ca\r
 550         �wз !\r
 551         \88�\82���a ;\r
 552 \r
 553 : \95�.�E��     -1 * \95�.��\9fe�� ;\r
 554 \r
 555 : �e�q.\88a    ( dx dy -- )\r
 556         \88�\82���a\r
 557         �A\9d���á @ +            ( dx y+dy )\r
 558         �A\8da �A\9d���á !         ( dx y+dy )\r
 559         �a\8e� \88a\9d���á @ +       ( y+dy x+dx )\r
 560         �A\8da \88a\9d���á !         ( y+dy x+dx )\r
 561         �a\8e�                    ( x+dx y+dy )\r
 562         \9d�.\8ba��\r
 563         \88�\82���a ;\r
 564 \r
 565 : �|�a\9d�   ( l -- )\r
 566         �A\8da                    ( l l )\r
 567         �wз @ sin*             ( l dx )\r
 568         �a\8e�                    ( dx l )\r
 569         �wз @ cos*             ( dx dy )\r
 570         �e�q.\88a  ;\r
 571 \r
 572 : \96�\9d�     ( \88�\9f� -- )\r
 573         -1 *  �|�a\9d� ;\r
 574 \r
 575 : __��\9fe��.��\8d�   ( \88�\9f� �U�\81  -- )\r
 576         0 �\91   5 \95�.��\9fe��   �A\8da �|�a\9d�  5 \95�.��\9fe��   \95��a   ��\9da ;\r
 577 \r
 578 : ��\9fe��.��\8d�   ( �e��\9fq \88b\95� -- )\r
 579         �a\8e�  355 2034 */       ( \88b\95� \88�\9f� ) ( ��\8d��i 10\95��� \90a\92\81�� \8ba\9f� )\r
 580                                         ( 2*pi*r*\88b\95�/360*10 = pi*r*\88b\95�/18 )\r
 581                                         ( pi = 355/113 = 3.141593 )\r
 582         �A\8da >\96A                        ( \96A\95��� \94ᣡ�A \88�\9f�\9fi \88i�\81\9f�)\r
 583         \88�\90�  10 /              ( \88b\95� \88�\9f� �U�\81 )\r
 584         __��\9fe��.��\8d�           ( \88b\95� )\r
 585         10 \90a�ỡ               ( \88b\95�_\90a�ỡ )\r
 586         �A\8da \96A>                ( \88b\95�_\90a�ỡ \88b\95�_\90a�ỡ \88�\9f� )\r
 587         ( 10�a\9d� \90a\92\85 \90a�ỡ \88b\95��A �\81\94w�a\93e \88�\9f��e�q �|�a\9d� \88q)\r
 588         *  10 /  �|�a\9d�         ( \88b\95�_\90a�ỡ )\r
 589         \95�.��\9fe��  ;\r
 590 \r
 591 : ��\9fe��.�� ( �e��\9fq -- )   360 ��\9fe��.��\8d� ;\r
 592 \r
 593 : __�E��.��\8d�   ( \88�\9f� �U�\81  -- )\r
 594         0 �\91   5 \95�.�E��   �A\8da �|�a\9d�  5 \95�.�E��   \95��a   ��\9da ;\r
 595 \r
 596 : �E��.��\8d�     ( �e��\9fq \88b\95� -- )\r
 597         �a\8e�  355 2034 */       ( \88b\95� \88�\9f� ) ( ��\8d��i 10\95��� \90a\92\81�� \8ba\9f� )\r
 598                                         ( 2*pi*r*\88b\95�/360*10 = pi*r*\88b\95�/18 )\r
 599         �A\8da >\96A                        ( \96A\95��� \94ᣡ�A \88�\9f�\9fi \88i�\81\9f�)\r
 600         \88�\90�  10 /              ( \88b\95� \88�\9f� �U�\81 )\r
 601         __�E��.��\8d�             ( \88b\95� )\r
 602         10 \90a�ỡ               ( \88b\95�_\90a�ỡ )\r
 603         �A\8da \96A>                ( \88b\95�_\90a�ỡ \88b\95�_\90a�ỡ \88�\9f� )\r
 604              ( 10�a\9d� \90a\92\85 \90a�ỡ \88b\95��A �\81\94w�a\93e \88�\9f��e�q �|�a\9d� \88q)\r
 605         *  10 /  �|�a\9d�         ( \88b\95�_\90a�ỡ )\r
 606         \95�.�E��  ;\r
 607 \r
 608 : �E��.�� ( �e��\9fq -- )   360 �E��.��\8d� ;\r
 609 \r
 610 : \91A��   ( �a\8b� -- )\r
 611         4 0  �\91   �A\8da �|�a\9d�   90 \95�.��\9fe��   \95��a   ��\9da ;\r
 612 \r
 613 : \89så\91A��   ( -- )\r
 614         100 \91A��  200 \91A��  300 \91A��  400 \91A�� ;\r
 615 \r
 616 : \94a���a��\97a   ( -- )\r
 617         45 \95�.��\9fe��\r
 618         4 0 �\91  \89så\91A��  90 \95�.��\9fe��  \95��a ;\r
 619 \r
 620 : \8b��i   ( �a\8b� -- )\r
 621         �A\8da �|�a\9d�  �A\8da \91A��  \96�\9d� ;\r
 622 \r
 623 : �a��\8b��i   ( �a\8b� -- )\r
 624         6 0 �\91  �A\8da \8b��i  60 \95�.��\9fe��  \95��a ;\r
 625 \r
 626 : �a\9cq\88\81��   ( -- )\r
 627         100 �a��\8b��i  400 �a��\8b��i ;\r
 628 \r
 629 : \8d���   ( �a\8b� -- )\r
 630         �A\8da  90 ��\9fe��.��\8d�  90 \95�.��\9fe��\r
 631               90 ��\9fe��.��\8d�  90 \95�.��\9fe�� ;\r
 632 \r
 633 : \8d�     ( �a\8b� -- )\r
 634         8 0 �\91   �A\8da  \8d��� 45 \95�.��\9fe��   \95��a   ��\9da ;\r
 635 \r
 636 : \94a\9fe\8d���   ( �a\8b� -- )\r
 637         �A\8da  60 ��\9fe��.��\8d�  120 \95�.��\9fe��\r
 638               60 ��\9fe��.��\8d�  120 \95�.��\9fe�� ;\r
 639 \r
 640 : \94a\9fe\8d�     ( �a\8b� -- )\r
 641         6 0 �\91   �A\8da  \94a\9fe\8d��� 60 \95�.��\9fe��   \95��a   ��\9da ;\r
 642 \r
 643 : �\95�i   ( �a\8b� -- )\r
 644         �A\8da  90 �E��.��\8d�  �A\8da 90 ��\9fe��.��\8d�\r
 645         �A\8da  90 �E��.��\8d�       90 ��\9fe��.��\8d� ;\r
 646 \r
 647 : �\81     ( �a\8b� -- )\r
 648         9 0 �\91   �A\8da �\95�i  160 \95�.��\9fe��   \95��a  ��\9da ;\r
 649 \r
 650 : \88b�w     ( �a\8b� ����\9f��\81 -- )\r
 651         360 \88�\90� /  �a\8e�        ( �a\8b� \95�_\88b\95� ����\9f��\81 )\r
 652         0 �\91  \88�\90� �|�a\9d�  �A\8da \95�.��\9fe��  \95��a\r
 653         ��\9da ��\9da ;\r
 654 \r
 655 : �i   ( �e�\81_�\81 �y�� -- )\r
 656         \88�\90� \88�\90� *\r
 657         0 �\91  600 �|�a\9d�  \88�\90� \88�\90� 360 * �a\8e� / \95�.��\9fe��  \95��a\r
 658         ��\9da ��\9da ;\r
 659 \r
 660 : \94a\88b�w   ( �a\8b� \88b\95� -- )\r
 661         �wз @ >\96A                    ( \96A\95���\94ᣡ�A ��q �wз�i \88i�\81\9f�)\r
 662         ���A�\81��\r
 663            \88�\90� �|�a\9d� �A\8da \95�.��\9fe��\r
 664         �wз @  \96A@ = \8ca��            ( �wз�� ��q�wз\89� \88{�a�� \98\81\8ca�� \96A�\89��)\r
 665         ��\9da ��\9da  \96A> ��\9da ;         ( \88t\94ᣡ�� \96A\95��� \94ᣡ\9fi ���� )\r
 666 \r
 667 : \94a\88b�w�a\9cw5    5 0 �\91  450  72 \94a\88b�w  72 \95�.��\9fe��  \95��a ;\r
 668 : \94a\88b�w�a\9cw4    4 0 �\91  700 135 \94a\88b�w  90 \95�.��\9fe��  \95��a ;\r
 669 : \94a\88b�w�a\9cw12  12 0 �\91  15 \95�.��\9fe��  �\95\97i��  400 �|�a\9d�  �\95\90\81\9da\r
 670                          200 135 \94a\88b�w  15 \95�.��\9fe��  \95��a ;\r
 671 \r
 672 : \90a�\81   ( \88a��\88b\95� \88a��\8b��� \88a��á\8b��\81 -- )\r
 673         >\96A                             ( \88a��á\8b��\81\9fi \96A\95���\94ᣡ�A \88i�\81\9f�)\r
 674         \96A@ �e                          ( '\96A@ 0 <> �e' \89� \88{�q)\r
 675            \88�\90� \95�.�E��\r
 676            �A\8da 2 * �|�a\9d�\r
 677            \88�\90� \88�\90� \96A@ 1 - \96A�\89\9c�\r
 678            �A\8da 2 * \96�\9d�\r
 679            \88�\90� 2 * \95�.��\9fe��\r
 680            �A\8da �|�a\9d�\r
 681            \88�\90� \88�\90� \96A@ 1 - \96A�\89\9c�\r
 682            \96�\9d�  \95�.�E��\r
 683         �a\93��e  ��\9da ��\9da \9ca\r
 684         \96A> ��\9da ;\r
 685 \r
 686 �\81\9fe\88t ��\93i�a\8b�  20 ��\93i�a\8b� !\r
 687 : �w   ( \90a�� -- )\r
 688         �A\8da  0 = �e  ��\93i�a\8b� @ �|�a\9d�\r
 689               �a\93��e  �A\8da  0 > �e  �A\8da 1 - \96A�\89\9c�     (  \90a��-1 �w )\r
 690                                     90 \95�.��\9fe��\r
 691                                     1 \88�\90� - \96A�\89\9c�     (  1-\90a�� �w )\r
 692                             �a\93��e  -1 \88�\90� - \96A�\89\9c�    ( -1-\90a�� �w )\r
 693                                     90 \95�.�E��\r
 694                                      1 \88�\90� + \96A�\89\9c�    (  1+\90a�� �w )\r
 695               \9ca  \9ca\r
 696         ��\9da ;\r
 697 \r
 698 : ���a�i\r
 699     ��\88\85���e\r
 700     ." '\93i�\91'�a\9d� �e \88�\82\8ba\9f� �a\9d�\8ba\9c\91�i ���b�s\93�\94a." \94a�q�\89 \94a�q�\89\r
 701     ." ��Ǳ�i\97i�i ��\9da�e             '�i�a'           \9ca\89� á��\89�"  \94a�q�\89\r
 702     ." ��Ǳ�i�i ��\98�\89A �a\93e�� ��\9da�e '\95��\91�i \95��\91�i'  ��\9c� á��\89�"  \94a�q�\89\r
 703     ." DOS\9d� \95��a \88a\9da�e             '\8f{'           ��\9ca\89� á������." \94a�q�\89\r
 704     ." \8ba\9f�\89� \8bi�a\9fi \88{�� ��\9da�e '�����e' \98a\9d� ��\9da�e '��\88\85���e'��\9ca\89� á������"\r
 705     \94a�q�\89\r
 706     �\95\90\81\9da\r
 707     300 \8d�  450 \8d�  600 \8d�\r
 708     �\95\97i��  90 \95�.�E��  2000 �|�a\9d�  �\95\90\81\9da\r
 709     900 \94a\9fe\8d�  700 \94a\9fe\8d�  500 \94a\9fe\8d�\r
 710     �\95\97i��  4000 \96�\9d�  90 \95�.��\9fe��  �\95\90\81\9da\r
 711     300 Ё\r
 712     1 \8bi�A��\9db�w�\81 ! ;       \ �e\8bi��\9db\r
 713 \r
 714 ���a�i\r
 715 \r
 716 : TURTLE-hi\r
 717     DOSCommand>PAD\r
 718     GET-MODE TO OldMode# HGRAPHIC hi\r
 719     ." �\81\89e\89� �A�e\89� ���w�i �a���I wykoh\9d� ��\90\81 �\81������." CR\r
 720     S" BLOCKS.BLK" MAPPED-TO-BLOCK\r
 721     ���a�i  QUIT ;\r
 722 \r
 723 ' TURTLE-hi TO 'boot\r
 724 \r
 725 ( \94a�q�i �a\9d\81\9d� ���a��������. )\r
 726 ( \94a���a��\97a )\r
 727 ( 400 \8b��i  400 �a��\8b��i  �a\9cq\88\81�� )\r
 728 ( 400 3 \88b�w   400 5 \88b�w   400 7 \88b�w )\r
 729 ( 5 2 �i  7 2 �i  7 3 �i  8 3 �i  9 2 �i  9 4 �i  10 3 �i  11 3 �i  11 5 �i )\r
 730 ( \94a\88b�w�a\9cw5 )\r
 731 ( \94a\88b�w�a\9cw5 )\r
 732 ( \94a\88b�w�a\9cw12 )\r
 733 ( 30 400 4 \90a�\81 )\r
 734 ( 20 250 5 \90a�\81 )\r
 735 ( 20 250 6 \90a�\81 )\r
 736 ( 50 ��\93i�a\8b� !   9 �w )\r
 737 ( 20 ��\93i�a\8b� !  12 �w )\r
 738 \r
 739 [ELSE]\r
 740 \r
 741 DECIMAL\r
 742 10 CONSTANT scale\r
 743 0 VALUE PenDown?\r
 744 VARIABLE Heading\r
 745 MAX-X 8 * 2/ VALUE xOffset\r
 746 MAX-Y 16 * 2/ VALUE yOffset\r
 747 VARIABLE xCoord  xOffset xCoord !\r
 748 VARIABLE yCoord  yOffset yCoord !\r
 749 \r
 750 : PENUP   ( -- )     FALSE TO PenDown? ;\r
 751 : PENDOWN ( -- )     TRUE  TO PenDown? ;\r
 752 : LINES-SCREEN ( y -- )   MAX-Y SWAP - TO YTop ;\r
 753 : FULL-SCREEN  ( -- )     PAGE ;\r
 754 \r
 755 : TODRAW ( x y -- )\r
 756     scale / yOffset SWAP -          \ x y1\r
 757     SWAP scale / xOffset + SWAP     \ x1 y1\r
 758     PenDown? IF 2DUP xCoord @ yCoord @ line640 THEN\r
 759     yCoord !  xCoord ! ;\r
 760 \r
 761 : SHOW-TURTLE ( -- )\r
 762     xCoord @  8 Heading @ 270 + sin* +\r
 763     yCoord @  8 Heading @ 270 + cos* -\r
 764     2DUP xCoord @ yCoord @ xline640             \ x1 y1\r
 765     xCoord @  16 Heading @ sin* +\r
 766     yCoord @  16 Heading @ cos* -               \ x1 y1 x2 y2\r
 767     2SWAP 2OVER xline640                        \ x2 y2\r
 768     xCoord @  8 Heading @ 90 + sin* +\r
 769     yCoord @  8 Heading @ 90 + cos* -           \ x2 y2 x3 y3\r
 770     2SWAP 2OVER xline640                        \ x3 y3\r
 771     xCoord @  yCoord @  xline640 ;\r
 772 \r
 773 : CLEAR-SCREEN ( -- )   YTop PAGE 0 OVER AT-XY TO YTop SHOW-TURTLE ;\r
 774 \r
 775 DECIMAL\r
 776 \r
 777 VARIABLE X-POSITION\r
 778 VARIABLE Y-POSITION\r
 779 \r
 780 : HOME   ( -- )\r
 781         SHOW-TURTLE\r
 782         0 Heading !\r
 783         0 X-POSITION !\r
 784         0 Y-POSITION !\r
 785         0 0 TODRAW\r
 786         SHOW-TURTLE ;\r
 787 \r
 788 : CLEAR-SCREEN   ( -- )\r
 789         PENUP  HOME CLEAR-SCREEN PENDOWN ;\r
 790 \r
 791 : SPLIT-SCREEN  ( -- )    8 LINES-SCREEN  CLEAR-SCREEN ;\r
 792 : FULL-SCREEN   ( -- )    FULL-SCREEN     CLEAR-SCREEN ;\r
 793 \r
 794 : RIGHT  ( angle -- )\r
 795         SHOW-TURTLE\r
 796         Heading @ +\r
 797         DUP 0 < IF\r
 798                    BEGIN 360 +\r
 799                    DUP -1 > UNTIL\r
 800                  ELSE 360 MOD\r
 801                  THEN\r
 802         Heading !\r
 803         SHOW-TURTLE ;\r
 804 \r
 805 : LEFT     -1 * RIGHT ;\r
 806 \r
 807 : DELTA-MOVE    ( dx dy -- )\r
 808         SHOW-TURTLE\r
 809         Y-POSITION @ +          ( dx y+dy )\r
 810         DUP Y-POSITION !        ( dx y+dy )\r
 811         SWAP X-POSITION @ +     ( y+dy x+dx )\r
 812         DUP X-POSITION !        ( y+dy x+dx )\r
 813         SWAP                    ( x+dx y+dy )\r
 814         TODRAW\r
 815         SHOW-TURTLE ;\r
 816 \r
 817 : FORWARD   ( length -- )\r
 818         DUP                     ( l l )\r
 819         Heading @ sin*          ( l dx )\r
 820         SWAP                    ( dx l )\r
 821         Heading @ cos*          ( dx dy )\r
 822         DELTA-MOVE  ;\r
 823 \r
 824 : BACK     ( length -- )\r
 825         -1 *  FORWARD ;\r
 826 \r
 827 : ARCR1   ( step times  -- )\r
 828         0 DO   5 RIGHT   DUP FORWARD  5 RIGHT   LOOP   DROP ;\r
 829 \r
 830 : ARCR   ( radius degrees -- )\r
 831         SWAP  355 2034 */\r
 832         DUP >R\r
 833         OVER  10 /\r
 834         ARCR1\r
 835         10 MOD\r
 836         DUP R>\r
 837         *  10 /  FORWARD\r
 838         RIGHT  ;\r
 839 \r
 840 : CIRCLER ( radius -- )   360 ARCR ;\r
 841 \r
 842 : ARCL1   ( step times  -- )\r
 843         0 DO   5 LEFT   DUP FORWARD  5 LEFT   LOOP   DROP ;\r
 844 \r
 845 : ARCL     ( radius degrees -- )\r
 846         SWAP  355 2034 */\r
 847         DUP >R\r
 848         OVER  10 /\r
 849         ARCL1\r
 850         10 MOD\r
 851         DUP R>\r
 852         *  10 /  FORWARD\r
 853         LEFT  ;\r
 854 \r
 855 : CIRCLEL ( radius -- )   360 ARCL ;\r
 856 \r
 857 : SQUARE   ( size -- )\r
 858         4 0  DO   DUP FORWARD   90 RIGHT   LOOP   DROP ;\r
 859 \r
 860 : BOXES   ( -- )\r
 861         100 SQUARE  200 SQUARE  300 SQUARE  400 SQUARE ;\r
 862 \r
 863 : DIAMONDS   ( -- )\r
 864         45 RIGHT\r
 865         4 0 DO  BOXES  90 RIGHT  LOOP ;\r
 866 \r
 867 : FLAG   ( size -- )\r
 868         DUP FORWARD  DUP SQUARE  BACK ;\r
 869 \r
 870 : 6FLAG   ( size -- )\r
 871         6 0 DO  DUP FLAG  60 RIGHT  LOOP ;\r
 872 \r
 873 : SPINFLAG   ( -- )\r
 874         100 6FLAG  400 6FLAG ;\r
 875 \r
 876 : PETAL1   ( size -- )\r
 877         DUP  90 ARCR  90 RIGHT\r
 878              90 ARCR  90 RIGHT ;\r
 879 \r
 880 : FLOWER1     ( size -- )\r
 881         8 0 DO   DUP  PETAL1 45 RIGHT   LOOP   DROP ;\r
 882 \r
 883 : PETAL2   ( size -- )\r
 884         DUP  60 ARCR  120 RIGHT\r
 885              60 ARCR  120 RIGHT ;\r
 886 \r
 887 : FLOWER2     ( size -- )\r
 888         6 0 DO   DUP  PETAL2 60 RIGHT   LOOP   DROP ;\r
 889 \r
 890 : RAY   ( size -- )\r
 891         DUP  90 ARCL  DUP 90 ARCR\r
 892         DUP  90 ARCL       90 ARCR ;\r
 893 \r
 894 : SUN     ( size -- )\r
 895         9 0 DO   DUP RAY  160 RIGHT   LOOP  DROP ;\r
 896 \r
 897 : REGULAR     ( size vertices -- )\r
 898         360 OVER /  SWAP\r
 899         0 DO  OVER FORWARD  DUP RIGHT  LOOP\r
 900         DROP DROP ;\r
 901 \r
 902 : STARS   ( vertices times -- )\r
 903         OVER OVER *\r
 904         0 DO  600 FORWARD  OVER OVER 360 * SWAP / RIGHT  LOOP\r
 905         DROP DROP ;\r
 906 \r
 907 : POLY   ( size angle -- )\r
 908         Heading @ >R\r
 909         BEGIN\r
 910            OVER FORWARD DUP RIGHT\r
 911         Heading @  R@ = UNTIL\r
 912         DROP DROP  R> DROP ;\r
 913 \r
 914 : POLYDEMO5    5 0 DO  450  72 POLY  72 RIGHT  LOOP ;\r
 915 : POLYDEMO4    4 0 DO  700 135 POLY  90 RIGHT  LOOP ;\r
 916 : POLYDEMO12  12 0 DO  15 RIGHT  PENUP   400 FORWARD  PENDOWN\r
 917                          200 135 POLY  15 RIGHT  LOOP ;\r
 918 \r
 919 : TREE   ( angle length recursion -- )\r
 920         >R\r
 921         R@ IF\r
 922            OVER LEFT\r
 923            DUP 2 * FORWARD\r
 924            OVER OVER R@ 1 - RECURSE\r
 925            DUP 2 * BACK\r
 926            OVER 2 * RIGHT\r
 927            DUP FORWARD\r
 928            OVER OVER R@ 1 - RECURSE\r
 929            BACK  LEFT\r
 930         ELSE  DROP DROP THEN\r
 931         R> DROP ;\r
 932 \r
 933 VARIABLE DRAGON-SIZE  20 DRAGON-SIZE !\r
 934 : DRAGON   ( n -- )\r
 935         DUP  0 = IF  DRAGON-SIZE @ FORWARD\r
 936               ELSE  DUP  0 > IF     DUP 1 - RECURSE\r
 937                                     90 RIGHT\r
 938                                     1 OVER - RECURSE\r
 939                              ELSE  -1 OVER - RECURSE\r
 940                                     90 LEFT\r
 941                                     1 OVER + RECURSE\r
 942               THEN  THEN\r
 943         DROP ;\r
 944 \r
 945 : HELLO\r
 946     SPLIT-SCREEN\r
 947     ." Starting Turtle Graphics implemented in hForth." CR CR\r
 948     ." Type 'FULL-SCREEN' for full screen text display." CR\r
 949     ." Type 'SPLIT-SCREEN' for text display in split screen." CR\r
 950     CR\r
 951     PENDOWN\r
 952     300 FLOWER1  450 FLOWER1  600 FLOWER1\r
 953     PENUP   90 LEFT  2000 FORWARD  PENDOWN\r
 954     900 FLOWER2  700 FLOWER2  500 FLOWER2\r
 955     PENUP   4000 BACK  90 RIGHT  PENDOWN\r
 956     300 SUN ;\r
 957 \r
 958 HELLO\r
 959 \r
 960 : TURTLE-hi\r
 961     DOSCommand>PAD\r
 962     GET-MODE TO OldMode# HGRAPHIC hi\r
 963     S" BLOCKS.BLK" MAPPED-TO-BLOCK\r
 964     HELLO  QUIT ;\r
 965 \r
 966 ' TURTLE-hi TO 'boot\r
 967 \r
 968 ( Try the followings: )\r
 969 ( DIAMONDS )\r
 970 ( 400 FLAG  400 6FLAG  SPINFLAG )\r
 971 ( 400 3 REGULAR   400 5 REGULAR   400 7 REGULAR )\r
 972 ( 5 2 STARS  7 2 STARS  7 3 STARS  8 3 STARS  9 2 STARS  9 4 STARS  10 3 STARS  11 3 STARS  11 5 STARS )\r
 973 ( POLYDEMO5 )\r
 974 ( POLYDEMO5 )\r
 975 ( POLYDEMO12 )\r
 976 ( 30 400 4 TREE )\r
 977 ( 20 250 5 TREE )\r
 978 ( 20 250 6 TREE )\r
 979 ( 50 DRAGON-SIZE !   9 DRAGON )\r
 980 ( 20 DRAGON-SIZE !  12 DRAGON )\r
 981 \r
 982 [THEN]\r
 983 \r
 984 SET-CURRENT  SET-ORDER\r
 985 BASE !\r