dsforth/emit6.zas

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; 6x8 font printing engine
   3 ;; the font was stolen from the
   4 ;; BYTEX font editor, (c) BYTEX Group
   5 ;; all dumb code is mine.
   6 ;; all smart code is taken from
   7 ;; the font editor & slighly tweaked.
   8 ;;                            Ketmar
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 font6x8:
  12   incbin "font6x8.fnt"
  13
  14 $FORTH_CONST (E6FONT)      font6x8
  15 $FORTH_CONST (E6CURXY)     emit6y
  16 $FORTH_CONST (E6CURX)      emit6x
  17 $FORTH_CONST (E6CURY)      emit6y
  18 $FORTH_CONST (E6WASSCROLL) emit6wasscrl
  19 $FORTH_CONST CONWIDTH      42
  20
  21 emit6wasscrl: defb 0
  22 ;; current pos x & y
  23 emit6y: defb 0
  24 emit6x: defb 0
  25
  26 ;; internal EmitChar
  27 ;; in: L=char
  28 emit6_internal:
  29   push  hl
  30
  31 ;; check for the new line
  32   ld    hl,emit6y
  33   ld    a,(emit6x)
  34   cp    42
  35   jr    c,emit6i_0   ;; no new line
  36   xor   a
  37   ld    (emit6x),a
  38   inc   (hl)
  39
  40 emit6i_0:
  41 ;; check for scroll
  42   ld    a,(hl)
  43   cp    22
  44   jr    c,emit6i_1   ;; no scroll
  45
  46 ;; do scroll
  47   ld    (hl),21
  48   ld    hl,emit6wasscrl
  49   inc   (hl)
  50   call  #0DFE    ;; CL-SC-ALL
  51
  52 emit6i_1:
  53   pop   hl
  54   push  ix
  55
  56 ;; print char
  57 ;; in: L=code
  58 ;;     E=y
  59 ;;     D=x
  60 ;; draw6InvMask: char inverse mask (norm: #00; inv: #FC)
  61 ;; draw6CharMask: screen AND mask (norm: #03; over: #FF)
  62 ;; draw6PutALU0: OR(#B2)/XOR(#AA) -- curr. XOR
  63 ;; draw6PutALU1: OR(#B3)/XOR(#AB) -- curr. XOR
  64 DrawChar6:
  65   ld    h,0
  66   add   hl,hl
  67   add   hl,hl
  68   add   hl,hl
  69   ld    bc,font6x8
  70   add   hl,bc
  71   push  hl
  72   pop   ix
  73
  74 ;; calc screen address
  75   ld    de,(emit6y)
  76   rlc   e
  77   rlc   e
  78   rlc   e
  79   rlc   d
  80   ld    a,d
  81   rlc   d
  82   add   a,d
  83   ld    d,a
  84   ld    a,e
  85   and   a
  86   rra
  87   scf
  88   rra
  89   and   a
  90   rra
  91   xor   e
  92   and   #F8
  93   xor   e
  94   ld    h,a
  95   ld    a,d
  96   rlca
  97   rlca
  98   rlca
  99   xor   e
 100   and   #C7
 101   xor   e
 102   rlca
 103   rlca
 104   ld    l,a
 105   ld    a,d
 106   and   7
 107
 108   rra
 109   ld    (Draw6Shift),a                 ;  [#00] [#00]
 110   ld    b,8
 111
 112 Draw6LineLoop:
 113   push  bc
 114   ld    a,(IX+0)
 115 draw6InvMask: equ $+1
 116   xor   #00
 117   ld    d,a
 118   ld    e,0
 119   exx
 120 draw6CharMask: equ $+2
 121   ld    de,#03FF
 122   exx
 123 Draw6Shift: equ $+1
 124   ld    a,#00
 125 ;;
 126   or    a
 127   jr    z,Draw6SkipShift
 128
 129 Draw6ShiftLoop:
 130   or    a
 131   rr    d
 132   rr    e
 133   rr    d
 134   rr    e
 135   exx
 136   scf
 137   rr    d
 138   rr    e
 139   rr    d
 140   rr    e
 141   exx
 142   dec   a
 143   jr    nz,Draw6ShiftLoop
 144
 145 Draw6SkipShift:
 146   ld    a,(hl)
 147   exx
 148   and   d
 149   exx
 150 draw6PutALU0:
 151   xor   d
 152   ld    (hl),a
 153   inc   l
 154   ld    a,l
 155   and   #1F              ;; char byte is zero?
 156   jr    z,Draw6SkipPut
 157   ld    a,(hl)
 158   exx
 159   and   e
 160   exx
 161 draw6PutALU1:
 162   xor   e
 163   ld    (hl),a
 164
 165 Draw6SkipPut:
 166   dec   l
 167   inc   h
 168   inc   ix
 169   pop   bc
 170   djnz  Draw6LineLoop
 171
 172   pop   ix
 173
 174   ld    hl,emit6x
 175   inc   (hl)
 176   ret
 177 ;; end of internal EmitChar
 178
 179
 180 ;; internal CR proc
 181 cr6internal:
 182 ;; check for the new line
 183   xor   a
 184   ld    (emit6x),a
 185
 186 cr6i_0:
 187   ld    hl,emit6y
 188   inc   (hl)
 189
 190 ;; check for scroll
 191   ld    a,(hl)
 192   cp    22
 193   ret   c        ;; no scroll
 194
 195 ;; do scroll
 196   ld    (hl),21
 197   ld    hl,emit6wasscrl
 198   inc   (hl)
 199   jp    #0DFE    ;; CL-SC-ALL
 200 ;; end of internal CR proc
 201
 202
 203 ;; draw one char, advance pos, scroll if necessary
 204 $FORTH_CODE_WORD XEMIT
 205 ;; ( c -- )
 206   pop   hl
 207 doxemit6:
 208   push  bc
 209   call  emit6_internal
 210   pop   bc
 211   jp    i_next
 212 $FORTH_END_CODE_WORD XEMIT
 213
 214
 215 ;; clear screen
 216 $FORTH_CODE_WORD CLS
 217 docls6:
 218   ld    hl,0
 219   ld    (emit6y),hl
 220
 221   push  bc
 222   ld    a,2
 223   call  #1601
 224   call  #0D6B
 225   pop   bc
 226   jp    i_next
 227 $FORTH_END_CODE_WORD CLS
 228
 229
 230 ;; backspace (back one char)
 231 $FORTH_CODE_WORD EMITBS
 232 ;; ( -- )
 233 dobs6:
 234   ld    hl,(emit6y)
 235   ld    a,h
 236   or    l
 237   jp    z,i_next   ;; can't move above the top
 238   ld    a,l
 239   or    a
 240   jr    z,bs6_0    ;; up one line
 241   dec   h          ;; left
 242   ld    (emit6y),hl
 243   jp    i_next
 244 bs6_0:
 245   ld    h,41
 246   dec   l
 247   ld    (emit6y),hl
 248   jp    i_next
 249 $FORTH_END_CODE_WORD EMITBS
 250
 251
 252 ;; draw one char, advance pos, scroll if necessary
 253 ;; it understands:
 254 ;;   #05 -- vtab (up)
 255 ;;   #06 -- go right
 256 ;;   #08 -- bs
 257 ;;   #09 -- tab
 258 ;;   #10 -- vtab
 259 ;;   #12 -- cls
 260 ;;   #13 -- cr (no line feed)
 261 $FORTH_CODE_WORD EMIT
 262 ;; ( c -- )
 263   pop   hl
 264   ld    a,l
 265 do_normal_emit_a:
 266   cp    5
 267   jr    nz,emit6_0
 268 ;;vtab (up)
 269   ld    a,(emit6y)
 270   or    a
 271   jp    z,i_next
 272   dec   a
 273   ld    (emit6y),a
 274   jp    i_next
 275 emit6_0:
 276   cp    6
 277   jr    nz,emit6_1
 278 ;;go right
 279   ld    hl,emit6x
 280   inc   (hl)
 281   jp    i_next
 282 emit6_1:
 283   cp    8
 284   jr    z,dobs6
 285   cp    9
 286   jr    z,dohtab6
 287   cp    10
 288   jr    z,dovtab6
 289   cp    12
 290   jr    z,docls6
 291   cp    13
 292   jp    nz,doxemit6
 293   xor   a
 294   ld    (emit6x),a
 295   jp    i_next
 296 $FORTH_END_CODE_WORD EMIT
 297
 298
 299 ;; do CR
 300 $FORTH_CODE_WORD CR
 301 ;; ( -- )
 302 docr6:
 303   push  bc
 304   call  cr6internal
 305   pop   bc
 306   jp    i_next
 307 $FORTH_END_CODE_WORD CR
 308
 309
 310 ;; vertical tab (#10)
 311 $FORTH_CODE_WORD VTAB
 312 ;; ( -- )
 313 dovtab6:
 314   push  bc
 315   call  cr6i_0
 316   pop   bc
 317   jp    i_next
 318 $FORTH_END_CODE_WORD VTAB
 319
 320
 321 ;; horizontal tab (#9)
 322 $FORTH_CODE_WORD HTAB
 323 ;; ( -- )
 324 dohtab6:
 325   push  bc
 326
 327   ld    a,(emit6x)
 328   cp    40
 329   jr    c,htab6_0   ;; no new line
 330   push  af
 331   call  cr6internal
 332   pop   af
 333   cp    42
 334   jr    c,htab6_q   ;; there were spaces, so tab is complete %-)
 335
 336 htab6_0:
 337   ld    a,(emit6x)
 338   ld    e,a
 339   or    #07
 340   inc   a
 341   sub   e
 342
 343 htab6_1:
 344   push  af
 345   ld    l,32
 346   call  emit6_internal
 347   pop   af
 348   dec   a
 349   jr    nz,htab6_1
 350
 351 htab6_q:
 352   pop   bc
 353   jp    i_next
 354 $FORTH_END_CODE_WORD HTAB
 355
 356 $FORTH_CODE_WORD WHEREX
 357 ;; ( -- x )
 358   ld    hl,emit6x
 359   ld    l,(hl)
 360   ld    h,0
 361   jp    i_pushhl
 362 $FORTH_END_CODE_WORD WHEREX
 363
 364 $FORTH_CODE_WORD WHEREY
 365 ;; ( -- y )
 366   ld    hl,emit6y
 367   ld    l,(hl)
 368   ld    h,0
 369   jp    i_pushhl
 370 $FORTH_END_CODE_WORD WHEREY
 371
 372 $FORTH_CODE_WORD GOTOXY
 373 ;; ( x y -- )
 374   ld    hl,emit6y
 375   pop   de
 376   ld    (hl),e
 377   dec   hl
 378
 379   pop   de
 380   ld    (hl),e
 381   jp    i_next
 382 $FORTH_END_CODE_WORD GOTOXY
 383
 384 $FORTH_CODE_WORD TOVER
 385 ;; ( n -- )
 386   ld    hl,draw6CharMask
 387   ld    (hl),#03
 388   pop   de
 389   ld    a,e
 390   or    a
 391   jr    z,tover0
 392   ld    (hl),#FF
 393   dec   a
 394   jr    z,tover1
 395 ;; mode 2 (OR)
 396   ld    a,#B2
 397   ld    (draw6PutALU0),a
 398   jr    tover2
 399 tover1:
 400 ;; mode 1 (XOR)
 401   ld    a,#AA
 402   ld    (draw6PutALU0),a
 403 tover2:
 404   inc   a
 405   ld    (draw6PutALU1),a
 406 tover0:
 407   jp    i_next
 408 $FORTH_END_CODE_WORD TOVER
 409
 410 $FORTH_CODE_WORD TOVER?
 411 ;; ( n -- )
 412   ld    a,(draw6CharMask)
 413   cp    #FF
 414   ld    hl,1
 415   jr    z,toverq0
 416   dec   l
 417 toverq0:
 418   jp    i_pushhl
 419 $FORTH_END_CODE_WORD TOVER?
 420
 421 $FORTH_CODE_WORD TINV
 422 ;; ( n -- )
 423   pop   de
 424   ld    a,e
 425   or    a
 426   jr    z,tinv0
 427   ld    a,#FC
 428 tinv0:
 429   ld    (draw6InvMask),a
 430   jp    i_next
 431 $FORTH_END_CODE_WORD TINV
 432
 433 $FORTH_CODE_WORD TINV?
 434 ;; ( n -- )
 435   ld    a,(draw6InvMask)
 436   ld    l,a
 437   ld    h,0
 438   or    a
 439   jr    z,tinvq0
 440   inc   l
 441 tinvq0:
 442   jp    i_pushhl
 443 $FORTH_END_CODE_WORD TINV?
 444
 445
 446 $FORTH_CODE_WORD SPACE
 447 ;; ( -- )
 448   ld    l,32
 449   jp    doxemit6
 450 $FORTH_END_CODE_WORD SPACE
 451
 452 $FORTH_CODE_WORD EMITCR
 453 ;; ( -- )
 454   xor   a
 455   ld    (emit6x),a
 456   jp    i_next
 457 $FORTH_END_CODE_WORD EMITCR
 458
 459 $FORTH_CODE_WORD SPACES
 460 ;; k8
 461 ;; ( n -- )
 462   pop   hl
 463   push  bc
 464 spaces0:
 465   ld    a,h
 466   cp    128
 467   jr    nc,spaces1
 468   or    l
 469   jr    z,spaces1
 470   push  hl
 471   ld    l,32
 472   call  emit6_internal
 473   pop   hl
 474   dec   hl
 475   jr    spaces0
 476 spaces1:
 477   pop   bc
 478   jp    i_next
 479 $FORTH_END_CODE_WORD SPACES
 480
 481
 482 $FORTH_WORD TYPE
 483 ;; AberSoft
 484 ;; ( addr len -- )
 485   dup 0 > 0BRANCH type1
 486   OVER + SWAP (DO)
 487 type0:
 488   I C@ EMIT
 489   (LOOP)  type0
 490   BRANCH type2
 491 type1:
 492   2DROP
 493 type2:
 494   ;S
 495 $FORTH_END_WORD TYPE
 496
 497 $FORTH_WORD XTYPE
 498 ;; AberSoft, k8
 499 ;; ( addr len -- )
 500   dup 0 > 0BRANCH xtype1
 501   OVER + SWAP (DO)
 502 xtype0:
 503   I C@ XEMIT
 504   (LOOP)  xtype0
 505   BRANCH xtype2
 506 xtype1:
 507   2DROP
 508 xtype2:
 509   ;S
 510 $FORTH_END_WORD XTYPE
 511
 512
 513 $FORTH_WORD (.") ;; "
 514 ;; AberSoft
 515   R@ COUNT dup 1+ R> + >R TYPE ;S
 516 $FORTH_END_WORD (.") ;; "