Set of Apple II Hard Drive Images/hard.hdv/HARD/FORTH/DRWPIANO.WRD

Text File | 1992-12-17 | 5.7 KB | 308 lines | [04] ASCII Text (0x0000)

\ FORTH WORDS FOR DRAWING PIANO DISPLAY SCREEN

DEC

: INVERSE  15 EMIT ;
: NORMAL   14 EMIT ;
: MOUSEON  27 EMIT ;
: MOUSEOFF 24 EMIT ;

: OCTAVE-TOP
   MOUSEON INVERSE
   ." NZNZNNZNZNZN"
   NORMAL MOUSEOFF
;
: OCTAVE-BOT
   MOUSEON INVERSE
   ."  | |N | | |N"
   NORMAL MOUSEOFF
;
: TOP-C
   MOUSEON INVERSE ." N" NORMAL MOUSEOFF
;
: AB-TOP
   MOUSEON INVERSE ." NZN" NORMAL MOUSEOFF
;
: AB-BOT
   MOUSEON INVERSE ."  |N" NORMAL MOUSEOFF
;

: CHNLLINE
   ." CHNL "
   10 0 DO
        2 SPACES I . 2 SPACES
   LOOP
   2 SPACES
   MOUSEON INVERSE
   ."  L LN L L LN"
   NORMAL MOUSEOFF
   TOP-C
;

: PROGLINE
   ." PROG "
   10 0 DO
        ." 00-00 "
   LOOP
   2 SPACES
   MOUSEON
   INVERSE SPACE NORMAL SPACE INVERSE SPACE NORMAL SPACE
   INVERSE ." N"
   INVERSE SPACE NORMAL SPACE INVERSE SPACE NORMAL SPACE
   INVERSE SPACE NORMAL SPACE
   INVERSE ." N"
   NORMAL MOUSEOFF
   TOP-C
;

: VLBRLINE   \ VOLUME & BRILLIANCE
   ." VLBR "
   10 0 DO
        ." 00-00 "
   LOOP
   2 SPACES
   OCTAVE-BOT
   TOP-C
;


: MRELINE1
   ." MRE  "
   AB-TOP
   6 0 DO
       OCTAVE-TOP
   LOOP
;
: MRELINE2
   ." 000  "
   AB-TOP
   6 0 DO
       OCTAVE-TOP
   LOOP
;
: PEDLLINE
   ." ---  "
   AB-BOT
   6 0 DO
       OCTAVE-BOT
   LOOP
;

: UNDERSCORES  ( N -- )   \ PRINTS N UNDERSCORES
   0 DO
     ASCII _ EMIT
   LOOP
;


: DRAWPIANO
   CR   3 PR#
   CHNLLINE
   PROGLINE
   VLBRLINE
   5 SPACES  75 UNDERSCORES
   MRELINE1
   MRELINE2
   PEDLLINE
   80 UNDERSCORES
   CR
   8 34 C!   \ PROTECT TOP WINDOW
;

DRAWPIANO

\ FORTH OBJECTS FOR CONTROLLING PIANO DISPLAY

HEX

\ ==============================================================
: ARRAY  ( #BYTES-PER-ELEMENT --- )  ( INDEX -- ADRS )
    CREATE C,
    DOES> DUP C@     \ --- INDEX, ADRS, BYTESPERENTRY
          ROT * + 1+ \ --- ADRS+ADRS*BYTES+1
;


\ ==============================================================
: FILLARRY
    7 0  DO    80 + DUP ,    LOOP  DROP
;
2 ARRAY LINEBASE
400  DUP , FILLARRY
428  DUP , FILLARRY
450  DUP , FILLARRY


\ ==============================================================
DEC
: FILLPIANOX
    80 5 DO   I C,   LOOP
    80 67 DO  I C,   LOOP
;
1 ARRAY PIANOX
    FILLPIANOX

: FILLPIANOY
    6 C, 5 C, 6 C,
    6 0 DO
           6 C, 5 C, 6 C, 5 C, 6 C,
           6 C, 5 C, 6 C, 5 C, 6 C, 5 C, 6 C,
    LOOP
           2 C, 1 C, 2 C, 1 C, 2 C,
           2 C, 1 C, 2 C, 1 C, 2 C, 1 C, 2 C, 2 C,
;
1 ARRAY PIANOY
    FILLPIANOY



\ ==============================================================
HEX
0 CONSTANT PEEK
1 CONSTANT POKE

4 OBJECT SCREEN
\ ======================
\ PARAMETERS:
\   1)XCOORD    0-79
\   2)YCOORD    0-23
\   3)CHARACTER 0-255
\   4)POKE OR PEEK   0=PEEK NONZERO=POKE
\     IF PEEK, STORES BYTE IN 3RD PARM
\ ========================
\ FORTH INTERFACE: X Y CHAR POKE/PEEK ---
BOT      LDA,
4 PARM   STA,  INX,  INX,
BOT      LDA,
3 PARM   STA,  INX,  INX,
BOT      LDA,
2 PARM   STA,  INX,  INX,
BOT      LDA,
1 PARM   STA,  INX,  INX,
\ ========================
OBJ-CODE
                   SEI,      \ NO INT WHEN WRITE TO 80COL
C001               STA,      \ ALLOW PAGE2 TO SWITCH  MAIN/AUX
2 PARM             LDA,
\
DEC 24 HEX         # CMP,    \ CLIP IF 24 OR OVER
CS IF,
         CLI,
         OBJ-EXIT
ELSE,
THEN,
                   .A ASL,   \ YCOORD*2 = OFFSET IN LINEBASE
                   TAX,
0 LINEBASE         ,X LDA,   \ GET ADRS-LO INTO ZP PTR: N-1
N 1 -              STA,
                   INX,
0 LINEBASE         ,X LDA,
N                  STA,
1 PARM             LDA,      \ GET XCOORD
\
DEC 80 HEX         # CMP,    \ CLIP IF 80 OR OVER
CS IF,
         CLI,
         OBJ-EXIT
ELSE,
THEN,
                   .A LSR,   \ DIVIDE BY 2 -
                   PHP,      \ SAVE CARRY FLAG FOR LATER
                   CLC,
         N 1 -     ADC,
         N 1 -     STA,      \ ADD XCOORD
         0         # LDA,
         N         ADC,
         N         STA,
                   PLP,      \ RESTORE CARRY FLAG
CS IF,                       \ IF ODD USE MAIN, ELSE AUX
         C054      STA,      \ SELECT MAIN 400-7FF
ELSE,
         C055      STA,
THEN,
         0         # LDY,
         4 PARM    LDA,      \ CHECK POKE OR PEEK
0= IF,
         N 1 -     )Y LDA,   \ PEEK THE BYTE
         3 PARM    STA,      \ INTO THIRD PARM
ELSE,
         3 PARM    LDA,
         N 1 -     )Y STA,   \ POKE THE BYTE
THEN,
         C054      STA,      \ RESELECT MAIN MEM
                   CLI,      \ ENABLE INT
OBJ-END
\ ==============================================

3 'PARM SCREEN CONSTANT PEEKADRS


3 OBJECT (PIANOXY)
\ ==============
\ PARAMETERS:
\ 1) NOTE NUMBER (INPUT)
\ 2) X COORDINATE (OUTPUT)
\ 3) Y COORDINATE (OUTPUT)
\ =========================
\ FORTH INTERFACE: (NOTE # -- )
BOT      LDA,
1 PARM   STA,  INX,  INX,
\ =========================
OBJ-CODE
         FF        # LDA,
         2 PARM    STA,      \ SET PARMS TO FF FF
         3 PARM    STA,      \ WILL BE CLIPPED BY SCREEN ROUTINE
         1 PARM    LDA,
         DEC 21    # CMP,    \ CLIP IF <21 OR >=109
CS NOT IF,
         OBJ-EXIT
THEN,
         DEC 109   # CMP,
CS IF,
         OBJ-EXIT
THEN,
                   SEC,
         DEC 21    # SBC,
                   TAX,
         0 PIANOX  ,X LDA,
         2 PARM    STA,
         0 PIANOY  ,X LDA,
         3 PARM    STA,
OBJ-END


\ ==============================================================
DEC
2 'PARM (PIANOXY) CONSTANT XADRS
3 'PARM (PIANOXY) CONSTANT YADRS

: PIANOXY ( NOTE # --- X Y )
    (PIANOXY)  XADRS C@ YADRS C@
;


: SAVEPIC
    128 0 DO
         I PIANOXY BL PEEK SCREEN
         PEEKADRS C@
         C,
    LOOP
;
1 ARRAY PICSAVE

\ MUST HAVE PIANO SCREEN UP FOR THIS:
SAVEPIC

HEX
\ TO INITIALIZE MIDI INTERFACE:
\ ============================
0 OBJECT INIT
OBJ-CODE
         13        # LDA,
         C0A8      STA,
         11        # LDA,
         C0A8      STA,
OBJ-END

INIT