imageFile/f/lib/5th_gfx

   1 : tab ( col -- spaces) 8 mod 8 swap - dup 0 = if drop 8 then ;\r
   2 \r
   3 : calccol ( b g r -- c )\r
   4 2B / 24 * swap 2B / 6 * + swap 2B / + ;\r
   5 \r
   6 : imgalloc ( x y -- handle )\r
   7 2dup * 8 + dynal        ( x y handle )\r
   8 dup push dynp           ( x y addr )\r
   9 rot over ! 4 + ! pop ;\r
  10 \r
  11 280 1E0 imgalloc const screen\r
  12 \r
  13 : imgsize ( screen -- x y )\r
  14 dynp dup @ swap 4 + @ ;\r
  15 \r
  16 : copyscreen ( srcDhand destDhand -- )\r
  17 swap dynp swap dup dynp swap dyns cmove ;\r
  18 \r
  19 : update ( -- ) screen dynp 8 + vidmap ;\r
  20 \r
  21 : point ( x y screen -- addr )\r
  22 dynp dup @      ( x y addr xs )\r
  23 rot *           ( x addr y*xs)\r
  24 + + 8 + ;\r
  25 \r
  26 : pset ( c x y screen -- ) point c! ;\r
  27 \r
  28 var tmp1 var tmp2\r
  29 : boxf ( x1 x2 y1 y2 screen c -- )\r
  30 tmp1 !\r
  31 tmp2 !\r
  32 for     ( x1 x2 )\r
  33         2dup swap - push\r
  34         over i2 tmp2 @ point\r
  35         tmp1 @ swap pop cfill\r
  36 loop 2drop ;\r
  37 rh tmp1 rh tmp2\r
  38 \r
  39 : cls ( screen -- )\r
  40 dynp dup @ swap 4 + dup @       ( x addr y )\r
  41 rot * swap 4 +                  ( len addr )\r
  42 0 rot rot swap                  ( c addr len)\r
  43 cfill ;\r
  44 \r
  45 : setpal ( b g r color -- ) 3C8 cprt! 3C9 cprt! 3C9 cprt! 3C9 cprt! ;\r
  46 \r
  47 : setupal\r
  48 D7\r
  49 6 do\r
  50         6 do\r
  51                 6 do\r
  52                         dup i C * swap i2 C * swap i3 C * swap setpal\r
  53                         1 -\r
  54                 loop\r
  55         loop\r
  56 loop\r
  57 drop ;\r
  58 \r
  59 setupal\r
  60 \r
  61 D" \listF\FNT_SYSTEM" fsDloadnew const font\r
  62 \r
  63 : scroll ( x y screen -- )\r
  64 dynp dup @ swap 4 + dup @ swap 4 + push ( x y xsize ysize  R: addr )\r
  65 over * push                             ( x y xsize        R: addr size )\r
  66 * + i2 + pop pop swap cmove ;\r
  67 \r
  68 var tmp1 var tmp2 var tmp3 var tmp4 var tmp5 var tmp6 var tmp7\r
  69 : scrollf ( color x y screen -- )\r
  70 dup push tmp1 ! ( screen )\r
  71 dup push tmp2 ! ( y )\r
  72 dup tmp3 !      ( x )\r
  73 pop pop scroll\r
  74 push\r
  75 tmp1 @ dynp dup @ tmp4 !        ( xsize )\r
  76 4 + @ tmp5 !                    ( ysize )\r
  77 tmp2 @ dup 0 - if\r
  78         0 > if\r
  79                 0 dup tmp6 ! tmp4 @ tmp5 @ tmp2 @ - dup tmp7 !\r
  80                 tmp5 @ tmp1 @ i boxf\r
  81 \r
  82         else\r
  83                 0 tmp4 @ 0 tmp2 @ neg dup tmp6 ! tmp1 @ i boxf\r
  84                 tmp5 @ tmp7 !\r
  85         then\r
  86 else\r
  87         drop\r
  88         0 tmp6 ! tmp5 @ tmp7 !\r
  89 then\r
  90 \r
  91 tmp3 @ dup 0 - if\r
  92         0 > if\r
  93                 tmp4 @ dup tmp3 @ - swap tmp6 @ tmp7 @ tmp1 @ i boxf\r
  94         else\r
  95                 0 tmp3 @ neg tmp6 @ tmp7 @ tmp1 @ i boxf\r
  96         then\r
  97 else\r
  98         drop\r
  99 then\r
 100 pop drop ;\r
 101 rh tmp1 rh tmp2 rh tmp3 rh tmp4 rh tmp5 rh tmp6 rh tmp7\r
 102 \r
 103 var curx\r
 104 var cury\r
 105 var curc\r
 106 var curb\r
 107 var emitscreen\r
 108 \r
 109 screen emitscreen !\r
 110 \r
 111 : at! ( x y -- ) cury ! curx ! ;\r
 112 : at@ ( -- x y ) curx @ cury @ ;\r
 113 : curc! calccol curc ! ;\r
 114 : curb! calccol curb ! ;\r
 115 \r
 116 : colnorm       FF FF FF curc! 0  0  0  curb! ;\r
 117 : colneg        0  0  0  curc! FF FF FF curb! ;\r
 118 : colhigh       0  FF FF curc! 0  0  0  curb! ;\r
 119 \r
 120 colnorm\r
 121 \r
 122 : (emit2\r
 123 dup FE = if drop\r
 124         0 curx ! cury @ 1+\r
 125         dup 3B > if\r
 126                 0 0 8 emitscreen @ scrollf\r
 127                 drop 3B\r
 128         then\r
 129         cury !\r
 130 else\r
 131         dup FC - if\r
 132                 dup FD - if\r
 133                         curx @ 4F > if FE emit then\r
 134                         8 * font dynp +\r
 135                         curc @ swap curb @ swap emitscreen @ dynp\r
 136                         curx @ 8 * cury @ 8 * charput\r
 137                         curx @ 1+ curx !\r
 138                 else\r
 139                         drop curx @ tab do space loop\r
 140                 then\r
 141         else\r
 142                 drop curx @ 1-\r
 143                 dup 0 < if drop 0 then curx !\r
 144         then\r
 145 then ;\r
 146 \r
 147 screen cls\r
 148 FC emit\r
 149 ' (emit2 ' emit is\r