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 emit6_line_count equ 24  ;; was 22
  15 emit6_line_width equ 42
  16
  17 $FORTH_CONST (E6FONTADDR)   font6x8_addr
  18 font6x8_addr: defw font6x8_data
  19
  20 $FORTH_CONST (E6CURXY)      emit6y
  21 $FORTH_CONST (E6CURX)       emit6x
  22 $FORTH_CONST (E6CURY)       emit6y
  23 $FORTH_CONST (E6WASSCROLL)  emit6wasscrl
  24 $FORTH_CONST CONWIDTH       emit6_line_width
  25
  26 emit6_attrp equ 23693
  27
  28 emit6wasscrl: defb 0
  29 ;; current pos x & y
  30 emit6y: defb 0
  31 emit6x: defb 0
  32
  33   IF USE_PRINT_ATTRS
  34 emit6_allowattr: defb 1
  35
  36 $FORTH_CONST EMIT-ATTRS? 1
  37
  38 $FORTH_CODE_WORD TATTRS
  39 ;; k8
  40 ;; ( flag -- )
  41 ;; allow attr setting
  42   pop   hl
  43   ld    a,h
  44   or    l
  45   jr    z,fword_tattrz_zero
  46   ld    a,1
  47 fword_tattrz_zero:
  48   ld    (emit6_allowattr),a
  49   jp    i_next
  50 $FORTH_END_CODE_WORD TATTRS
  51
  52 $FORTH_CODE_WORD TATTRS?
  53 ;; k8
  54 ;; ( -- flag )
  55   ld    a,(emit6_allowattr)
  56   ld    l,a
  57   ld    h,0
  58   jp    i_pushhl
  59 $FORTH_END_CODE_WORD TATTRS?
  60
  61 ;; scroll up
  62 emit6_do_scroll_subr:
  63   call  #0DFE    ;; CL-SC-ALL
  64   ; set attribute for the lower part
  65   ld    hl,scrattr8x8(0,23)
  66   ld    de,scrattr8x8(1,23)
  67   ld    a,(emit6_attrp)
  68   ld    (hl),a
  69   ld    bc,31
  70   ldir
  71   ret
  72
  73   ELSE
  74 $FORTH_CONST EMIT-ATTRS? 0
  75 emit6_do_scroll_subr equ #0DFE    ;; CL-SC-ALL
  76
  77 $FORTH_CODE_WORD TATTRS
  78 ;; k8
  79 ;; ( flag -- )
  80 ;; allow attr setting
  81   pop   hl
  82   jp    i_next
  83 $FORTH_END_CODE_WORD TATTRS
  84
  85 $FORTH_CODE_WORD TATTRS?
  86 ;; k8
  87 ;; ( -- flag )
  88   ld    hl,0
  89   jp    i_pushhl
  90 $FORTH_END_CODE_WORD TATTRS?
  91
  92   ENDIF
  93
  94 ;; internal EmitChar
  95 ;; in: L=char
  96 emit6_internal:
  97   push  hl
  98
  99 ;; check for the new line
 100   ld    hl,emit6y
 101   ld    a,(emit6x)
 102   cp    emit6_line_width
 103   jr    c,emit6i_0   ;; no new line
 104   xor   a
 105   ld    (emit6x),a
 106   inc   (hl)
 107
 108 emit6i_0:
 109 ;; check for scroll
 110   ld    a,(hl)
 111   cp    emit6_line_count
 112   jr    c,emit6i_1   ;; no scroll
 113
 114 ;; do scroll
 115   ld    (hl),emit6_line_count-1
 116   ld    hl,emit6wasscrl
 117   inc   (hl)
 118   call  emit6_do_scroll_subr
 119
 120 emit6i_1:
 121   pop   hl
 122   push  ix
 123
 124 ;; print char
 125 ;; in: L=code
 126 ;;     E=y
 127 ;;     D=x
 128 ;; draw6InvMask: char inverse mask (norm: #00; inv: #FC)
 129 ;; draw6CharMask: screen AND mask (norm: #03; over: #FF)
 130 ;; draw6PutALU0: OR(#B2)/XOR(#AA) -- curr. XOR
 131 ;; draw6PutALU1: OR(#B3)/XOR(#AB) -- curr. XOR
 132 DrawChar6:
 133   ld    h,0
 134   add   hl,hl
 135   add   hl,hl
 136   add   hl,hl
 137   ld    bc,(font6x8_addr)
 138   add   hl,bc
 139   push  hl
 140   pop   ix
 141
 142 ;; calc screen address
 143   ld    de,(emit6y)
 144   rlc   e
 145   rlc   e
 146   rlc   e
 147   rlc   d
 148   ld    a,d
 149   rlc   d
 150   add   a,d
 151   ld    d,a
 152   ld    a,e
 153   and   a
 154   rra
 155   scf
 156   rra
 157   and   a
 158   rra
 159   xor   e
 160   and   #F8
 161   xor   e
 162   ld    h,a
 163   ld    a,d
 164   rlca
 165   rlca
 166   rlca
 167   xor   e
 168   and   #C7
 169   xor   e
 170   rlca
 171   rlca
 172   ld    l,a
 173   ld    a,d
 174   and   7
 175
 176   IF USE_PRINT_ATTRS
 177   ld    (emit6_scraddr),hl
 178   ld    (emit6_scrofs),a
 179   ENDIF
 180
 181   rra
 182   ld    (Draw6Shift),a                 ;  [#00] [#00]
 183   ld    b,8
 184
 185 Draw6LineLoop:
 186   push  bc
 187   ld    a,(IX+0)
 188 draw6InvMask: equ $+1
 189   xor   #00
 190   ld    d,a
 191   ld    e,0
 192   exx
 193 draw6CharMask: equ $+2
 194   ld    de,#03FF
 195   exx
 196 Draw6Shift: equ $+1
 197   ld    a,#00
 198 ;;
 199   or    a
 200   jr    z,Draw6SkipShift
 201
 202 Draw6ShiftLoop:
 203   or    a
 204   rr    d
 205   rr    e
 206   rr    d
 207   rr    e
 208   exx
 209   scf
 210   rr    d
 211   rr    e
 212   rr    d
 213   rr    e
 214   exx
 215   dec   a
 216   jr    nz,Draw6ShiftLoop
 217
 218 Draw6SkipShift:
 219   ld    a,(hl)
 220   exx
 221   and   d
 222   exx
 223 draw6PutALU0:
 224   xor   d
 225   ld    (hl),a
 226   inc   l
 227   ld    a,l
 228   and   #1F              ;; char byte is zero?
 229   jr    z,Draw6SkipPut
 230   ld    a,(hl)
 231   exx
 232   and   e
 233   exx
 234 draw6PutALU1:
 235   xor   e
 236   ld    (hl),a
 237
 238 Draw6SkipPut:
 239   dec   l
 240   inc   h
 241   inc   ix
 242   pop   bc
 243   djnz  Draw6LineLoop
 244
 245   pop   ix
 246
 247   ld    hl,emit6x
 248   inc   (hl)
 249
 250   IF USE_PRINT_ATTRS
 251   ld    a,(emit6_allowattr)
 252   or    a
 253   ret   z
 254   ; set attr
 255   ld    hl,0
 256 emit6_scraddr equ $-2
 257   ; conver to attribute
 258   ld   a,h
 259   rrca
 260   rrca
 261   rrca
 262   and  #03
 263   or   #58
 264   ld   h,a
 265   ; set
 266   ld    a,(emit6_attrp)
 267   ld    (hl),a
 268   ex    af,af'
 269   ; check shift
 270   ld    a,0
 271 emit6_scrofs equ $-1
 272   cp    3
 273   ret   c
 274   inc   hl
 275   ex    af,af'
 276   ld    (hl),a
 277   ENDIF
 278
 279   ret
 280 ;; end of internal EmitChar
 281
 282
 283 ;; internal CR proc
 284 cr6internal:
 285 ;; check for the new line
 286   xor   a
 287   ld    (emit6x),a
 288
 289 cr6i_0:
 290   ld    hl,emit6y
 291   inc   (hl)
 292
 293 ;; check for scroll
 294   ld    a,(hl)
 295   cp    emit6_line_count
 296   ret   c        ;; no scroll
 297
 298 ;; do scroll
 299   ld    (hl),emit6_line_count-1
 300   ld    hl,emit6wasscrl
 301   inc   (hl)
 302   jp    #0DFE    ;; CL-SC-ALL
 303 ;; end of internal CR proc
 304
 305
 306 ;; draw one char, advance pos, scroll if necessary
 307 $FORTH_CODE_WORD XEMIT
 308 ;; k8
 309 ;; ( c -- )
 310   pop   hl
 311 doxemit6:
 312   push  bc
 313   call  emit6_internal
 314   pop   bc
 315   jp    i_next
 316 $FORTH_END_CODE_WORD XEMIT
 317
 318
 319 ;; clear screen
 320 $FORTH_CODE_WORD CLS
 321 ;; AberSoft, k8
 322 docls6:
 323   ld    hl,0
 324   ld    (emit6y),hl
 325   IF USE_EMIT8_DRIVER
 326   ld    (emit8_coordx),hl
 327   ENDIF
 328
 329   push  bc
 330   ld    a,2
 331   call  #1601
 332   call  #0D6B
 333   pop   bc
 334   jp    i_next
 335 $FORTH_END_CODE_WORD CLS
 336
 337
 338 ;; backspace (back one char)
 339 $FORTH_CODE_WORD EMITBS
 340 ;; k8
 341 ;; ( -- )
 342 dobs6:
 343   ld    hl,(emit6y)
 344   ld    a,h
 345   or    l
 346   jp    z,i_next   ;; can't move above the top
 347   ld    a,l
 348   or    a
 349   jr    z,bs6_0    ;; up one line
 350   dec   h          ;; left
 351   ld    (emit6y),hl
 352   jp    i_next
 353 bs6_0:
 354   ld    h,emit6_line_width-1
 355   dec   l
 356   ld    (emit6y),hl
 357   jp    i_next
 358 $FORTH_END_CODE_WORD EMITBS
 359
 360
 361 ;; draw one char, advance pos, scroll if necessary
 362 ;; it understands:
 363 ;;   #05 -- vtab (up)
 364 ;;   #06 -- go right
 365 ;;   #08 -- bs
 366 ;;   #09 -- tab
 367 ;;   #10 -- vtab
 368 ;;   #12 -- cls
 369 ;;   #13 -- cr (no line feed)
 370 $FORTH_CODE_WORD EMIT
 371 ;; k8
 372 ;; ( c -- )
 373   pop   hl
 374   ld    a,l
 375 do_normal_emit_a:
 376   cp    5
 377   jr    nz,emit6_0
 378 ;;vtab (up)
 379   ld    a,(emit6y)
 380   or    a
 381   jp    z,i_next
 382   dec   a
 383   ld    (emit6y),a
 384   jp    i_next
 385 emit6_0:
 386   cp    6
 387   jr    nz,emit6_1
 388 ;;go right
 389   ld    hl,emit6x
 390   inc   (hl)
 391   jp    i_next
 392 emit6_1:
 393   cp    8
 394   jr    z,dobs6
 395   cp    9
 396   jr    z,dohtab6
 397   cp    10
 398   jr    z,dovtab6
 399   cp    12
 400   jr    z,docls6
 401   cp    13
 402   jp    nz,doxemit6
 403   xor   a
 404   ld    (emit6x),a
 405   jp    i_next
 406 $FORTH_END_CODE_WORD EMIT
 407
 408
 409 ;; do CR
 410 $FORTH_CODE_WORD CR
 411 ;; k8
 412 ;; ( -- )
 413 docr6:
 414   push  bc
 415   call  cr6internal
 416   pop   bc
 417   jp    i_next
 418 $FORTH_END_CODE_WORD CR
 419
 420
 421 ;; scroll up
 422 $FORTH_CODE_WORD VSCROLL
 423 ;; k8
 424 ;; ( -- )
 425   push  bc
 426   call  emit6_do_scroll_subr
 427   pop   bc
 428   jp    i_next
 429 $FORTH_END_CODE_WORD VSCROLL
 430
 431
 432 ;; vertical tab (#10)
 433 $FORTH_CODE_WORD VTAB
 434 ;; k8
 435 ;; ( -- )
 436 dovtab6:
 437   push  bc
 438   call  cr6i_0
 439   pop   bc
 440   jp    i_next
 441 $FORTH_END_CODE_WORD VTAB
 442
 443 ;; horizontal tab (#9)
 444 $FORTH_CODE_WORD HTAB
 445 ;; k8
 446 ;; ( -- )
 447 dohtab6:
 448   push  bc
 449
 450   ld    a,(emit6x)
 451   cp    40
 452   jr    c,htab6_0   ;; no new line
 453   push  af
 454   call  cr6internal
 455   pop   af
 456   cp    emit6_line_width
 457   jr    c,htab6_q   ;; there were spaces, so tab is complete %-)
 458
 459 htab6_0:
 460   ld    a,(emit6x)
 461   ld    e,a
 462   or    #07
 463   inc   a
 464   sub   e
 465
 466 htab6_1:
 467   push  af
 468   ld    l,32
 469   call  emit6_internal
 470   pop   af
 471   dec   a
 472   jr    nz,htab6_1
 473
 474 htab6_q:
 475   pop   bc
 476   jp    i_next
 477 $FORTH_END_CODE_WORD HTAB
 478
 479
 480 $FORTH_CODE_WORD WHEREX
 481 ;; k8
 482 ;; ( -- x )
 483   ld    a,(emit6x)
 484 wherexy_common:
 485   ld    l,a
 486   ld    h,0
 487   jp    i_pushhl
 488 $FORTH_END_CODE_WORD WHEREX
 489
 490 $FORTH_CODE_WORD WHEREY
 491 ;; k8
 492 ;; ( -- y )
 493   ld    a,(emit6y)
 494   jr    wherexy_common
 495 $FORTH_END_CODE_WORD WHEREY
 496
 497 $FORTH_CODE_WORD GOTOXY
 498 ;; k8
 499 ;; ( x y -- )
 500   pop   hl  ; l=y
 501   pop   de  ; e=x
 502   ld    h,e
 503   ld    (emit6y),hl
 504   jp    i_next
 505 $FORTH_END_CODE_WORD GOTOXY
 506
 507
 508 $FORTH_CODE_WORD TOVER
 509 ;; k8
 510 ;; ( n -- )
 511   ld    hl,draw6CharMask
 512   ld    (hl),#03
 513   pop   de
 514   ld    a,e
 515   or    a
 516   jr    z,tover0
 517   ld    (hl),#FF
 518   dec   a
 519   jr    z,tover1
 520 ;; mode 2 (OR)
 521   ld    a,#B2
 522   ld    (draw6PutALU0),a
 523   jr    tover2
 524 tover1:
 525 ;; mode 1 (XOR)
 526   ld    a,#AA
 527   ld    (draw6PutALU0),a
 528 tover2:
 529   inc   a
 530   ld    (draw6PutALU1),a
 531 tover0:
 532   jp    i_next
 533 $FORTH_END_CODE_WORD TOVER
 534
 535 $FORTH_CODE_WORD TOVER?
 536 ;; k8
 537 ;; ( n -- )
 538   ld    a,(draw6CharMask)
 539   cp    #FF
 540   ld    hl,1
 541   jr    z,toverq0
 542   dec   l
 543 toverq0:
 544   jp    i_pushhl
 545 $FORTH_END_CODE_WORD TOVER?
 546
 547 $FORTH_CODE_WORD TINV
 548 ;; k8
 549 ;; ( n -- )
 550   pop   de
 551   ld    a,e
 552   or    a
 553   jr    z,tinv0
 554   ld    a,#FC
 555 tinv0:
 556   ld    (draw6InvMask),a
 557   jp    i_next
 558 $FORTH_END_CODE_WORD TINV
 559
 560 $FORTH_CODE_WORD TINV?
 561 ;; k8
 562 ;; ( n -- )
 563   ld    a,(draw6InvMask)
 564   ld    l,a
 565   ld    h,0
 566   or    a
 567   jr    z,tinvq0
 568   inc   l
 569 tinvq0:
 570   jp    i_pushhl
 571 $FORTH_END_CODE_WORD TINV?
 572
 573
 574 $FORTH_CODE_WORD SPACE
 575 ;; k8
 576 ;; ( -- )
 577   ld    l,32
 578   jp    doxemit6
 579 $FORTH_END_CODE_WORD SPACE
 580
 581 $FORTH_CODE_WORD EMITCR
 582 ;; k8
 583 ;; ( -- )
 584   xor   a
 585   ld    (emit6x),a
 586   jp    i_next
 587 $FORTH_END_CODE_WORD EMITCR
 588
 589 $FORTH_CODE_WORD SPACES
 590 ;; k8
 591 ;; ( n -- )
 592   pop   hl
 593   push  bc
 594 spaces0:
 595   ld    a,h
 596   cp    128
 597   jr    nc,spaces1
 598   or    l
 599   jr    z,spaces1
 600   push  hl
 601   ld    l,32
 602   call  emit6_internal
 603   pop   hl
 604   dec   hl
 605   jr    spaces0
 606 spaces1:
 607   pop   bc
 608   jp    i_next
 609 $FORTH_END_CODE_WORD SPACES
 610
 611
 612 $FORTH_WORD TYPE
 613 ;; AberSoft
 614 ;; ( addr len -- )
 615   dup 0 > 0BRANCH type1
 616   OVER + SWAP (DO)
 617 type0:
 618   I C@ EMIT
 619   (LOOP)  type0
 620   BRANCH type2
 621 type1:
 622   2DROP
 623 type2:
 624   ;S
 625 $FORTH_END_WORD TYPE
 626
 627 $FORTH_WORD XTYPE
 628 ;; AberSoft, k8
 629 ;; ( addr len -- )
 630   dup 0 > 0BRANCH xtype1
 631   OVER + SWAP (DO)
 632 xtype0:
 633   I C@ XEMIT
 634   (LOOP)  xtype0
 635   BRANCH xtype2
 636 xtype1:
 637   2DROP
 638 xtype2:
 639   ;S
 640 $FORTH_END_WORD XTYPE
 641
 642
 643   IF USE_PRINT_ATTRS|USE_EMIT8_DRIVER
 644 $FORTH_CONST SV-ATTR_P emit6_attrp
 645
 646 $FORTH_CODE_WORD PAPER
 647 ;; k8
 648 ;; ( -- n )
 649   pop   de
 650   ld    a,e
 651   and   7
 652   rlca
 653   rlca
 654   rlca
 655   ld    e,a
 656   ld    hl,emit6_attrp
 657   ld    a,(hl)
 658   and   0o0307
 659   or    e
 660   ld    (hl),a
 661   jp    i_next
 662 $FORTH_END_CODE_WORD PAPER
 663
 664 $FORTH_CODE_WORD INK
 665 ;; k8
 666 ;; ( -- n )
 667   pop   de
 668   ld    a,e
 669   and   7
 670   ld    e,a
 671   ld    hl,emit6_attrp
 672   ld    a,(hl)
 673   and   0o0370
 674   or    e
 675   ld    (hl),a
 676   jp    i_next
 677 $FORTH_END_CODE_WORD INK
 678
 679 $FORTH_CODE_WORD FLASH
 680 ;; k8
 681 ;; ( -- n )
 682   pop   de
 683   ld    a,e
 684   or    a
 685   jr    z,fword_flash_zero
 686   ld    e,0o0200
 687 fword_flash_zero:
 688   ld    hl,emit6_attrp
 689   ld    a,(hl)
 690   and   0o0177
 691   or    e
 692   ld    (hl),a
 693   jp    i_next
 694 $FORTH_END_CODE_WORD FLASH
 695
 696 $FORTH_CODE_WORD BRIGHT
 697 ;; k8
 698 ;; ( -- n )
 699   pop   de
 700   ld    a,e
 701   or    a
 702   jr    z,fword_bright_zero
 703   ld    e,0o0100
 704 fword_bright_zero:
 705   ld    hl,emit6_attrp
 706   ld    a,(hl)
 707   and   0o0277
 708   or    e
 709   ld    (hl),a
 710   jp    i_next
 711 $FORTH_END_CODE_WORD BRIGHT
 712   ENDIF
 713
 714   include "main_emit8.zas"