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