"Loading XY Display Support" $PRINT CRLF
; mod 3/15/02 - added CLF 7 to -XYDISPLAY
; mod 10/12/02 - added ROCKS, removed others, char tweeks
; core mod 10/8/02 - +XYDISPLAY allows up to 32K DL length
; Original code from 9/9/02 and before
; with N_ROCKS 6/20/04
; 12/15/07 - modified -XYDISPLAY to avoid conflict w/CFGE
; 1/30/08 - modified -XYDISPLAY to use 0 for dummy vector
;---------------------------------------------------------
;
; EXPERIMENTAL POINT PLOT DISPLAY DRIVERS FOR HP-IPL/OS
; USES 12555A DUAL D/A BOARD TO DRIVE OSCILLOSCPE DISPLAY
; CONVERTED TO CREATE SYNTAX
;
; DANGER - HIGHLY COMPLEX CRAP TAKES PLACE HERE!
; MANY DRAGONS WITHIN, THIS CODE USES DMA AND INTERUPTS.
;
; THEORY OF OPERATION:
; THE +XYDISPLAY KEYWORDS PATCHES LOW MEMORY AND LOADS CODE
; FOR DCPC CH2 COMPLETION INTERUPTS, SAVES THE DISPLAY LIST
; PARAMETERS IN LOCAL VARIABLES, THE LOADS THE DMA HARDWARE
; ONCE THE SYSTEM IS PRESET, IRQ'S ARE ENABLED AND THE CRT
; REFRESH TIMER ON THE 12555A IS STARTED.  CONTROL IS THEN
; GIVEN BACK TO HP-IPL/OS.
; WHEN THE 12555A GENERATES AN INTERUPT REQUEST THE DCPC
; HARDWARE TRANSFERS THE DISPLAY LIST TO THE A/D CONVERTERS.
; UPON DCPC TRANSFER COMPLETION AN IRQ TO LOCATION 000007 IS
; VECTORED TO CODE WITHIN +XYDISPLAY KEYWORD TO RESETS THE
; DCPC HARDWARE AND RESETS THE REFRESH TIMER SO THE CRT WILL
; BE REFRESHED AUTOMATICALLY.
;
; Req. !IRQ/-IRQ
;
"Loading +XYDISPLAY" $PRINT CRLF
;
; +XYDISPLAY
; USEAGE:
; (DISPLAY LIST ADDRESS) (DISPLAY LIST LENGHT) +XYDISP
;
OCTAL CREATE +XYDISPLAY
*
SLOT    EQU 20          * set to 12555 slot
*
* SETUP DCPC COMPLETE IRQ INSTRUCTION AT 000007B
        LDB XYC0        * GET DCPC CH2 IRQ ADDRESS
        LDA XYC1        * GET DCPC IRQ INSTRUCTION
        STA 000001,I    * STORE IRQ INSTRUCTION AT ADDRESS
* SETUP DCPC IRQ LINKAGE INSTRUCTIONS AT 000075-77
        LDB XYC2        * GET LINKAGE ADDRESS
        CLA             * CLEAR A REGISTER = NOP
        STA 000001,I    * STORE A NOP AT 0000075
        INB             * INCREMENT B REGISTER
        LDA XYC3        * NEXT IRQ LINK INSTRUCTION
        STA 000001,I    * STORE AT 000076
        INB             * INCREMENT B REGISTER
        LDA XYC4        * NEXT IRQ LINK INSTRUCTION
        STA 000001,I    * STORE AT 000077
        JMP PRPAR       * SKIP LOCAL CONSTANTS AND VARIABLES
*
* XY DISPLAY LOCAL VARIABLES AND CONSTANTS
*
XYC0    OCT 000007      * DCPC CHANNEL 2 IRQ
XYC1    JSB 000075      * DCPC CH2 DONE IRQ INSTRUCTION
XYC2    OCT 000075      * DCPC IRQ LINKAGE ADDRESS
XYC3    JMP 000077,I    * INDIRECT JUMP TO ADDR IN 77B
XYC4    DEF XYREF       * DISPLAY REFRESH ROUTINE ADDRESS
XYC5    OCT 077777      * DISPLAY LIST ADDRESS MASK
XYC6    OCT 077777      * DISPLAY LENGHT MASK = 32K MAX
XYC7    DEF SLOT        * DCPC CONTROL WORD FOR 12555A
XYAD    OCT 000000      * DISPLAY LIST ADDRESS VARIABLE
XYLN    OCT 000000      * DISPLAY LIST LENGHT VARIABLE
*
* PROCESS HP-IPL/OS DISPLAY LIST PARAMETERS
*
PRPAR   JSB ZSPOP,I     * POP DISPLAY LIST LENGHT
        AND XYC6        * MASK TO 4K MAXIMUM
        CMA,INA         * 2'S COMPLEMENT
        STA XYLN        * SAVE IN LOCAL VARIABLE
        JSB ZSPOP,I     * POP DISPLAY LIST ADDRESS
        AND XYC5        * MASK TO 32K MAXIMUM
        STA XYAD        * SAVE IN LOCAL VARIABLE
*
* PRESET DCPC HARDWARE FOR FIRST REFRESH CYCLE
*
        LDA XYC7        * GET DCPC CONTROL WORD
        OTA 7           * LOAD IT
        CLC 3           * PRESET FOR MEMORY ADDRESS
        LDA XYAD        * GET DISPLAY LIST ADDRESS
        OTA 3           * LOAD IT
        STC 3           * PRESET FOR TRANSFER LENGHT
        LDA XYLN        * GET DISPLAY LIST LENGHT
        OTA 3           * LOAD IT       
*
* ENABLE INTERUPT SYSTEM
*
        STF 00          * INTERUPTS ARE NOW ENABLED
*
* START THE 12555A DCPC DISPLAY REFRESH PROCESS
*
        CLF SLOT,C        * FLAG WILL AUTO-SET AFTER ~20 MS.
        STC 7,C         * START DCPC CONTROLLER
        JMP ZNXT,I      * RETURN TO HP-IPL/OS
*
* XY DISPLAY REFRESH ROUTINE BEGINS
* THIS CODE GETS RUN EACH TIME THE DISPLAY LIST HAS BEEN SENT
* TO THE 12555A D/A CONVERTER
*
XYREF   EQU *
*
* SAVE REGISTERS AND FLAGS
*
        JSB ISAVE,I
*
* THIS CODE STARTS UP DCPC CHANNEL 2
*
        LDA XYC7        * GET DCPC CONTROL WORD
        OTA 7           * LOAD IT
        CLC 3           * PRESET FOR MEMORY ADDRESS
        LDA XYAD        * GET DISPLAY LIST ADDRESS
        OTA 3           * LOAD IT
        STC 3           * PRESET FOR TRANSFER LENGHT
        LDA XYLN        * GET DISPLAY LIST LENGHT
        OTA 3           * LOAD IT
*
* THIS CODE STARTS THE NEXT DMA DISPLAY REFRESH
*
        CLF SLOT        * START 21555A REFRESH TIMER
        STC 7,C         * START DCPC CONTROLLER
*
* RESTORE REGISTERS AND FLAGS
*
        JSB IREST,I
*
* RETURN TO HP-IPL/OS FROM DISPLAY REFRESH IRQ
*
        JMP *+1,I       * INDIRECT JUMP TO ADDR+1
        OCT 100075      * INDIRECT POINTER TO RETURN ADDRESS
END
;
"Loading -XYDISPLAY" $PRINT CRLF
;
; -XYDISPLAY
; THIS TURNS OFF THE DISPLAY REFRESH FUNCTION
; changed 12/15/07 to not require consuming ZP locs
; and use somewhat different method
; changed 1/30/08 to use NOP for dummy handler
;
OCTAL CREATE -XYDISPLAY /KEEP
        STF 7        * set dma ch 2 flag to abort transfer
        CLC 7        * clear dma ch 2 control to disable
        LDA IDUMY    * get dummy vector call
        STA 7        * ints now go nowhere
        CLC SLOT     * disable XY board
        STF SLOT     * and set its flag to normal default
        JMP ZNXT,I   * return to hpiplos
IDUMY   OCT 0        * NOP to disable interrupt
END
;
"Loading XYDISP" $PRINT CRLF
;
; XYDISP
; A non-interrupt version, usage: listaddress len XYDISP
; Must call repeatedly or blanks
; 
OCTAL CREATE XYDISP /KEEP
 SFS SLOT
 JMP *-1
 JSB ZSPOP,I
 CMA,INA
 STA DLEN
 JSB ZSPOP,I
 STA 1
 CLF SLOT
LOOP LDA 1,I
 OTA SLOT
 INB
 ISZ DLEN
 JMP LOOP
 JMP END
DLEN OCT 0
END
;
"Loading draw variables" $PRINT CRLF
;
; draw functions
;
OCTAL
VARIABLE @DLBASE    ;display list base
VARIABLE @DLP       ;display list pointer
VARIABLE @DLI       ;plot intensity, 0=off,1=single,2=double,etc
VARIABLE @DLD       ;default intensity
VARIABLE @X         ;x save
VARIABLE @Y         ;y save
VARIABLE @BLANK     ;if zero, adds extra 0,0 after display list
@BLANK 1 PUT        ;default is blanking (no extra 0,0)
@DLP 0 PUT          ;set display list pointer to zero
@DLBASE 74000 PUT   ;set display list base to 74000
@DLI 2 PUT          ;set intensity to 2
@DLD 2 PUT          ;and also default intensity
;
"Loading PEN" $PRINT CRLF
;
; PEN   pops stack, sets @DLI to value
; use like..
; 20 20 PLOT 10 "N" DRAW 0 PEN 10 "E" DRAW 2 PEN 10 "S" DRAW
; use 2 PEN to create double entries in display list
; use 1 PEN to create single entries
; use 0 PEN to hide cursor to move relative without drawing
; use higher pens for "thicker" traces
;
DEFINE PEN
7 AND @DLI SWAP PUT
END
;
"Loading PEN+" $PRINT CRLF
;
; PEN+   sets @DLI to @DLD
;
DEFINE PEN+
@DLI @DLD GET PUT
END
;
"Loading PEN-" $PRINT CRLF
;
; PEN-   sets @DLI to 0
;
DEFINE PEN-
@DLI #0 PUT
END
;
"Loading DLRESET" $PRINT CRLF
;
; DLRESET    zero display list
;
DEFINE DLRESET
@DLP #0 PUT
PEN+ -XYDISPLAY
END
;
"Loading DL-" $PRINT CRLF
;
; DL-    erase last point(s) plotted
;
DEFINE DL-
@DLP GET IFNZ
 @DLP DUP GET @DLI GET SUB PUT
 @DLP GET IF<0 @DLP #0 PUT ENDIF
 @DLP GET IFZ
  -XYDISPLAY
 ELSE
  @DLBASE GET @DLP GET +XYDISPLAY
 ENDIF
ENDIF
END
;
"Loading PLOT" $PRINT CRLF
;
; PLOT   plot x y pixel, usage: x y PLOT
; Saves pixel point in @X @Y
;
DEFINE PLOT
OVER @X SWAP PUT ;save x in @X
@Y OVER PUT ;save y in @Y
@DLI GET IFZ  ;if zero thickness
 DROP ;do nothing
ELSE
 400 MUL ADD  ;calculate display list word value
 #1 @DLI GET +DO  ;loop DLI times
  @DLBASE GET @DLP GET ADD ;calculate where to put
  DUP IF<0  ;if overflow
   DROP  ;nop
  ELSE
   OVER PUT ;write data
   @DLP DUP GET INC PUT  ;increment pointer
  ENDIF
 +LOOP
 @DLBASE GET ;get display list start
 @DLP GET ;use DLP as length
 ;if @BLANK = 0 then plot extra 0 and inc length
 @BLANK GET IFZ
  #1 @DLD GET +DO  ;use default intensity for # 0's
   OVER OVER ADD #0 PUT INC
  +LOOP
 ENDIF
 +XYDISPLAY ;update display
ENDIF
DROP
END
;
"Loading DRAW" $PRINT CRLF
;
; DRAW   draw lines, distance on stack, direction string on X
; Valid directions.. "N" "S" "E" "W" "NE" "NW" "SE" "SW"
; Updates X/Y so subsequent draws can draw relative to last pos
; Example  20 20 PLOT 30 "N" DRAW 20 "E" DRAW 30 "S" DRAW
;
DEFINE DRAW
;convert to "star trek" directions 1-8
$LEN
DUP #1 SUB IFZ  ;if one character direction
 #0 $GET        ;get character
 CASE
 = 105 #1    ; "E" is direction 1
 = 116 3     ; "N" is direction 3
 = 127 5     ; "W" is direction 5
 = 123 7     ; "S" is direction 7
 DEFAULT #0  ; otherwise invalid
 ENDCASE
ELSE
 DUP 2 SUB IFZ  ;if two character direction
  #0 $GET 116 SUB IFZ  ;if 1st char is N
   #1 $GET CASE
   = 105 2   ; "NE" is direction 2
   = 127 4   ; "NW" is direction 4
   DEFAULT #0   ;else invalid
   ENDCASE
  ELSE
   #0 $GET 123 SUB IFZ  ;if 1st char is S
    #1 $GET CASE
    = 127 6   ; "SW" is direction 6
    = 105 10  ; "SE" is direction 8
    DEFAULT #0  ;else invalid
    ENDCASE
   ELSE
    #0  ;invalid direction
   ENDIF
  ENDIF
 ELSE
  #0  ;invalid direction  
 ENDIF
ENDIF
SWAP DROP $DROP  ;drop string and length
DUP IFZ "INVALID DIRECTION" $PRINT DROP DROP
ELSE
; direction on stack, distance over that
 SWAP ;now distance top of stack
 #1 SWAP +DO   ;loop for specified distance
  DUP CASE     ;branch on direction...
  = 1 @X DUP GET INC PUT  ;dir 1 "E" increment X
  = 2 @X DUP GET INC PUT  ;dir 2 "NE" increment x
      @Y DUP GET INC PUT  ;       and increment y
  = 3 @Y DUP GET INC PUT  ;dir 3 "N" increment y
  = 4 @X DUP GET DEC PUT  ;dir 4 "NW" decrement x
      @Y DUP GET INC PUT  ;       and increment y
  = 5 @X DUP GET DEC PUT  ;dir 5 "W" decrement y
  = 6 @X DUP GET DEC PUT  ;dir 6 "SW" decrement x
      @Y DUP GET DEC PUT  ;       and decrement y
  = 7 @Y DUP GET DEC PUT  ;dir 7 "S" decrement y
  = 10 @X DUP GET INC PUT ;dir 8 "SE" increment x
       @Y DUP GET DEC PUT ;       and decrement y
  ENDCASE
  @X GET @Y GET PLOT    ;plot the pixel
 +LOOP
 DROP ;drop the direction code
ENDIF
END
;
"Loading PUSHXY" $PRINT CRLF
;
; PUSHXY    save X and Y coordinates (on Z stack)
;
DEFINE PUSHXY
@X GET S>Z @Y GET S>Z
END
;
"Loading POPXY" $PRINT CRLF
;
; POPXY     restore X and Y coordidates from Z stack
;
DEFINE POPXY
@Y Z>S PUT @X Z>S PUT
END
;
"Loading UNPLOT" $PRINT CRLF
;
; UNPLOT    removes X and Y coordinate(s) from the DL
;
DEFINE UNPLOT
400 MUL ADD  ;calculate display list word value
@DLBASE GET  ;push DL start
DO           ;loop until I say
 OVER OVER GET SUB IFZ  ;if (ptr)=target x/y then
  ;move n+1 to end_of_list to n to end_of_list-1
  DUP INC @DLBASE GET @DLP GET ADD 
  +DO
   INDEX DUP GET SWAP DEC SWAP PUT
  +LOOP 
  @DLP DUP GET DEC PUT  ;decrement DL pointer (length)
  @DLBASE GET @DLP GET +XYDISPLAY  ;reset the display list
  #0  ;keep going
 ELSE
  DUP @DLBASE GET @DLP GET ADD SUB IF<0 ;if ptr < end_of_list
   INC  ;inc pointer
   #0   ;keep going
  ELSE
   #1   ;terminate
  ENDIF
 ENDIF
UNTIL
DROP  ;pointer
END
;----------------------------------------------------------
"Loading @FROM/@TO/XYMOVE" $PRINT CRLF
;
; @FROM - "variable", set to DL region start address
;
OCTAL CREATE @FROM
       LDA FRADR
       JSB ZSPSH,I
       JMP ZNXT,I
FRADR  DEF FROM
FROM   OCT 0
END
;
; @TO - "variable", set to DL region end address
;
OCTAL CREATE @TO /KEEP
       LDA TOADR
       JSB ZSPSH,I
       JMP ZNXT,I
TOADR  DEF TO
TO     OCT 0
END
;
; Xofs Yofs XYMOVE - moves region specified by @FROM/@TO
; by Xofs/Yofs - kinda like split word matrix math.. loops
; from @FROM to @TO and adds Xofs/Yofs to all words in range
;
OCTAL CREATE XYMOVE /KEEP
       JSB ZSPOP,I
       STA TMP1      save Y offset
       JSB ZSPOP,I
       STA TMP2      save X offset
       LDB FROM      starting address
LOOP   LDA 1,I       get data at (B)
       ALF,ALF       swap X into low byte
       AND C377      isolate just X coordinate
       ADA TMP2      add X coordinate
       AND C377      in case of overflow

       ALF,ALF       put back in high byte
       STA TMP3      save intermediate
       LDA 1,I       get data at (B)
       AND C377      isolate Y coordinate
       ADA TMP1      add Y offset
       AND C377      in case of overflow
       IOR TMP3      or with intermediate
       STA 1,I       put back in display list
       CPB TO        done?
       JMP ZNXT,I    yes, back to hpiplos
       INB           no, increment pointer
       JMP LOOP      and keep looping
C377   OCT 377
END
;----------------------------------------------------------
"Loading OCTAGON" $PRINT CRLF
;
; X Y Size OCTAGON    Size is size of one side
;
OCTAL DEFINE OCTAGON
S>Z ;save size
PLOT ;plot 1st pixel
Z>S ;restore size
"N" DUP DRAW "NE" DUP DRAW "E" DUP DRAW "SE" DUP DRAW
"S" DUP DRAW "SW" DUP DRAW "W" DUP DRAW "NW" DEC DRAW
END
;----------------------------------------------------------
"Loading PEN++" $PRINT CRLF
DEFINE PEN++
PEN+ @X GET @Y GET PLOT
END
;
"Loading $XYPRINT" $PRINT CRLF
;
; $XYPRINT - pops X and plots string on XY display
; @FSIZE determines size of segments
; @X and @Y determine lower-left corner of cell
; character begins at @X + @FSIZE, @Y + @FSIZE
; @X and @Y left at start of next character cell
; Char set: ABCDEFGHIJKLMNOPQRSTUVWXYZ!.:-/0123456789[cr]
; [cr] (dec 13) sets @Y to 30 and @X to @X - @FSIZE * 3
;
VARIABLE @FSIZE
OCTAL DEFINE $XYPRINT
@FSIZE GET IFZ  ;initialise...
 @FSIZE 6 PUT @X 10 PUT @Y 346 PUT
ENDIF
$LEN DUP IFZ DROP "Error" $PRINT ELSE
 #1 SWAP +DO  ;loop for each character in string
  @X GET S>Z @Y GET S>Z  ;save initial coordinates
  @X DUP GET @FSIZE GET ADD PUT ;set X/Y
  @Y DUP GET @FSIZE GET ADD PUT ;starting point
  @FSIZE GET  ;push font size for quick access
  $HEAD  ;trim 1st char and push to stack
  CASE
  = 101 ;A...
    @X GET @Y GET PLOT "N" DUP DRAW PUSHXY "E" DUP ROL DRAW
    "S" DUP DRAW POPXY "NE" DUP DRAW "SE" DUP DEC DRAW
  = 102 ;B...
    @X GET @Y GET PLOT "N" DUP ROL DRAW "E" DUP ROL DRAW
    "SW" DUP DRAW PUSHXY "W" DUP DRAW POPXY "SE" DUP DRAW
    "W" DUP ROL DRAW
  = 103 ;C...
    PEN- "E" DUP ROL DRAW "N" DUP ROR DRAW
    PEN++ "SW" DUP ROR DRAW "W" DUP DRAW
    "NW" DUP ROR DRAW "N" DUP DRAW "NE" DUP ROR DRAW
    "E" DUP DRAW "SE" DUP ROR DRAW
  = 104 ;D...
    @X GET @Y GET PLOT "N" DUP ROL DRAW "E" DUP DRAW
    "SE" DUP DRAW "SW" DUP DRAW "W" DUP DEC DRAW
  = 105 ;E...
    @X GET @Y GET PLOT PUSHXY "N" DUP DRAW PUSHXY "N" DUP DRAW
    "E" DUP ROL DRAW POPXY "E" DUP DRAW POPXY "E" DUP ROL DRAW
  = 106 ;F...
    @X GET @Y GET PLOT "N" DUP DRAW PUSHXY "N" DUP DRAW
    "E" DUP ROL DRAW POPXY "E" DUP DRAW
  = 107 ;G...
    PEN- "E" DUP DRAW "N" DUP DRAW
    PEN++ "E" DUP DRAW "S" DUP ROR DRAW
    "SW" DUP ROR DRAW "W" DUP DRAW "NW" DUP ROR DRAW
    "N" DUP DRAW "NE" DUP ROR DRAW "E" DUP DRAW
    "SE" DUP ROR DRAW
  = 110 ;H...
    @X GET @Y GET PLOT "N" DUP DRAW PUSHXY "N" DUP DRAW
    POPXY "E" DUP ROL DRAW PUSHXY "S" DUP DRAW
    POPXY "N" DUP DRAW
  = 111 ;I...
    PEN- "E" DUP ROR DRAW PEN++
    "E" DUP ROR DRAW PUSHXY "E" DUP ROR DRAW POPXY
    "N" DUP ROL DRAW PUSHXY "W" DUP ROR DRAW POPXY
    "E" DUP ROR DRAW
  = 112 ;J...
    PEN- "N" DUP ROR DRAW PEN++
    "SE" DUP ROR DRAW "E" DUP DRAW "NE" DUP ROR DRAW
    "N" DUP ROL DRAW
  = 113 ;K...
    @X GET @Y GET PLOT "N" DUP DRAW PUSHXY "N" DUP DRAW
    POPXY "E" DUP DRAW PUSHXY "NE" DUP DRAW POPXY "SE" DUP DRAW
  = 114 ;L...
    @X GET @Y GET PLOT PUSHXY "N" DUP ROL DRAW POPXY
    "E" DUP ROL DRAW
  = 115 ;M...
    @X GET @Y GET PLOT "N" DUP ROL DRAW "SE" DUP DRAW
    "NE" DUP DRAW "S" DUP ROL DRAW
  = 116 ;N...
    @X GET @Y GET PLOT "N" DUP ROL DRAW "SE" DUP ROL DRAW
    "N" DUP ROL DRAW
  = 117 ;O...
    PEN- "E" DUP ROR DRAW PEN++
    "NW" DUP ROR DRAW "N" DUP DRAW "NE" DUP ROR DRAW
    "E" DUP DRAW "SE" DUP ROR DRAW "S" DUP DRAW
    "SW" DUP ROR DRAW "W" DUP DEC DRAW
  = 120 ;P...
    @X GET @Y GET PLOT "N" DUP ROL DRAW "E" DUP OVER ROR ADD DRAW
    "SE" DUP ROR DRAW "SW" DUP ROR DRAW "W" DUP OVER ROR ADD DEC DRAW
  = 121 ;Q...
    PEN- "E" DUP ROR DRAW PEN++
    "NW" DUP ROR DRAW "N" DUP DRAW "NE" DUP ROR DRAW
    "E" DUP DRAW "SE" DUP ROR DRAW "S" DUP DRAW
    PUSHXY "SW" DUP ROR DRAW "W" DUP DEC DRAW
    POPXY PEN- "W" DUP ROR DRAW PEN++
    "SE" DUP ROR DRAW
  = 122 ;R...
    @X GET @Y GET PLOT "N" DUP ROL DRAW "E" DUP OVER ROR ADD DRAW
    "SE" DUP ROR DRAW "SW" DUP ROR DRAW "W" DUP ROR DRAW PUSHXY
    "W" DUP DRAW POPXY "SE" DUP DRAW
  = 123 ;S...
    PEN- "N" DUP ROR DRAW PEN++
    "SE" DUP ROR DRAW "E" DUP DRAW "NE" DUP ROR DRAW
    "NW" DUP ROR DRAW "W" DUP DRAW "NW" DUP ROR DRAW
    "NE" DUP ROR DRAW "E" DUP DRAW "SE" DUP ROR DRAW
  = 124 ;T...
    PEN- "E" DUP DRAW PEN++
    "N" DUP ROL DRAW PUSHXY "W" DUP DRAW POPXY "E" DUP DRAW
  = 125 ;U...
    PEN- "N" DUP ROL DRAW PEN++
    "S" DUP DRAW "S" DUP ROR DRAW "SE" DUP ROR DRAW
    "E" DUP DRAW "NE" DUP ROR DRAW "N" DUP ROR DRAW
    "N" DUP DRAW
  = 126 ;V...
    PEN- "N" DUP ROL DRAW PEN++
    "S" DUP DRAW "SE" DUP DRAW "NE" DUP DRAW "N" DUP DRAW
  = 127 ;W...
    PEN- "N" DUP ROL DRAW PEN++
    "S" DUP ROL DRAW "NE" DUP DRAW "SE" DUP DRAW
    "N" DUP ROL DRAW
  = 130 ;X...
    PUSHXY PEN- "N" DUP ROL DRAW PEN++
    "SE" DUP ROL DRAW POPXY "NE" DUP ROL DRAW
  = 131 ;Y...
    PEN- "N" DUP ROL DRAW PEN++
    "SE" DUP DRAW PUSHXY "NE" DUP DRAW POPXY "S" DUP DRAW
  = 132 ;Z...
    PEN- "N" DUP ROL DRAW PEN++
    "E" DUP ROL DRAW "SW" DUP ROL DRAW "E" DUP ROL DRAW
  = 41  ;!
    PEN- "E" DUP DRAW PEN++
    "NW" DUP ROR ROR INC DRAW "NE" DUP ROR ROR INC DRAW
    "SE" DUP ROR ROR INC DRAW "SW" DUP ROR ROR INC DRAW
    PEN- "N" DUP DRAW PEN++ "N" DUP DRAW
  = 56  ;.
    PEN- "E" DUP DRAW "N" DUP ROR ROR DRAW PEN++
  = 72  ;:
    PEN- "E" DUP DRAW "N" DUP ROR ROR DRAW PEN++
    PEN- "N" DUP DRAW PEN++
  = 55  ;-
    PEN- "N" DUP DRAW PEN++
    "E" DUP ROL DRAW
  = 57  ;/
    "NE" DUP ROL DRAW
  = 15  ;[CR]  set Y to Y - @FSIZE * 3, X to 10 - @FSIZE * 3
    ;changes saved values on Z stack
    Z>S @FSIZE GET 3 MUL SUB  ;adjust Y
    Z>S DROP 10 @FSIZE GET 3 MUL SUB ;adjust X
    S>Z S>Z  ;put back on Z stack
  = 60  ;0...
    PUSHXY "NE" DUP ROL DRAW POPXY
    PEN- "E" DUP ROR DRAW PEN++
    "NW" DUP ROR DRAW "N" DUP DRAW "NE" DUP ROR DRAW
    "E" DUP DRAW "SE" DUP ROR DRAW "S" DUP DRAW
    "SW" DUP ROR DRAW "W" DUP DEC DRAW
  = 61  ;1...
    PEN- "E" DUP ROR DRAW PEN++
    "E" DUP DRAW PEN- "W" DUP ROR DRAW PEN+ "N" DUP ROL DRAW
    "SW" DUP ROR DRAW
  = 62  ;2...
    PEN- "N" DUP ROR OVER ADD DRAW PEN++
    "NE" DUP ROR DRAW "E" DUP DRAW "SE" DUP ROR DRAW "SW" DUP
    ROR DRAW "W" DUP DRAW "SW" DUP ROR DRAW "S" DUP ROR DRAW
    "E" DUP ROL DRAW
  = 63  ;3...
    PEN- "N" DUP ROR DRAW PEN++
    "SE" DUP ROR DRAW "E" DUP DRAW "NE" DUP ROR DRAW
    "NW" DUP ROR DRAW PUSHXY "NE" DUP ROR DRAW "NW" DUP ROR DRAW
    "W" DUP DRAW "SW" DUP ROR DRAW POPXY "W" DUP ROR DRAW
  = 64  ;4...
    PEN- "E" DUP OVER ROR ADD DRAW PEN++
   "N" DUP ROL DRAW "SW" DUP DRAW "E" DUP OVER ROR ADD DRAW
  = 65  ;5...
    PEN- "NE" DUP ROL DRAW PEN++
    "W" DUP ROL DRAW "S" DUP DRAW "E" DUP OVER ROR ADD DRAW
    "SE" DUP ROR DRAW "SW" DUP ROR DRAW "W" DUP OVER ROR ADD DRAW
  = 66  ;6...
    PEN- "NE" DUP DRAW "N" DUP DRAW PEN++
    "SW" DUP DRAW "S" DUP ROR DRAW "SE" DUP ROR DRAW
    "E" DUP DRAW "NE" DUP ROR DRAW "NW" DUP ROR DRAW
    "W" DUP OVER ROR ADD DEC DRAW
  = 67  ;7...
    "NE" DUP ROL DRAW "W" DUP ROL DRAW
  = 70  ;8...
    PEN- "E" DUP ROR DRAW PEN++
    "E" DUP DRAW "NE" DUP ROR DRAW "NW" DUP ROR DRAW
    "W" DUP DRAW "NW" DUP ROR DRAW "NE" DUP ROR DRAW
    "E" DUP DRAW "SE" DUP ROR DRAW "SW" DUP ROR DRAW
    PEN- "W" DUP DRAW PEN+ "SW" DUP ROR DRAW
    "SE" DUP ROR DEC DRAW
  = 71  ;9...
    PEN- "E" DUP DRAW PEN++
    "NE" DUP DRAW "N" DUP ROR DRAW "NW" DUP ROR DRAW
    "W" DUP DRAW "SW" DUP ROR DRAW "SE" DUP ROR DRAW
    "E" DUP OVER ROR ADD DEC DRAW
  ENDCASE
  @Y Z>S PUT ;restore Y
  3 MUL  ;multiply @FSIZE by 3 (FSIZE still on stack)
  Z>S ADD  ;add to saved X position

  @X SWAP PUT ;restore X
 +LOOP
ENDIF $DROP
END
;----------------------------------------------------------
"Loading XYCRLF and XYHOME" $PRINT CRLF
;
OCTAL DEFINE XYCRLF
1 15 $CREATE $XYPRINT  ;send CR to $XYPRINT
END
;
OCTAL DEFINE XYHOME
@FSIZE GET IFZ @FSIZE 6 PUT ENDIF ;default if not set
@X 10 PUT @Y 370 @FSIZE GET 3 MUL SUB PUT ;set XY home
END
;----------------------------------------------------------
"Loading N_ROCKS" $PRINT CRLF
;
; Three Rocks moving around
; Uses locations 112-125
; Mod 6-2-04 to specify iterations on stack
;
OCTAL DEFINE N_ROCKS
112 0 PUT  ;loc 112 tracks current direction of rock #1
113 0 PUT  ;loc 113 tracks dir of rock #2
114 0 PUT  ;loc 114 tracks dir of rock #3
DLRESET    ;clear display list
@X 30 PUT @Y 170 PUT ;position X/Y
@FSIZE 10 PUT       ;set "font" size (size of segments)
"HP-IPL/OS" $XYPRINT   ;print string on display
@X 60 PUT @Y 110 PUT ;position X/Y
"ROCKS!" $XYPRINT  ;bold declaration
120 @DLBASE GET @DLP GET ADD PUT ;set region #1 from
50 50 14 OCTAGON  ;draw octagon #1
121 @DLP GET DEC @DLBASE GET ADD PUT  ;record region #1 to
122 @DLBASE GET @DLP GET ADD PUT ;set region #2 from
50 50 10 OCTAGON  ;draw octagon #2
123 @DLP GET DEC @DLBASE GET ADD PUT  ;record region #2 to
124 @DLBASE GET @DLP GET ADD PUT ;set region #3 from
50 50 5 OCTAGON  ;draw octagon #3
125 @DLP GET DEC @DLBASE GET ADD PUT  ;record region #3 to
; number of iterations on stack
DO  ;loop until stack is non-zero
;rock #1
 @FROM 120 GET PUT @TO 121 GET PUT
 #0  ;change-dir flag
 RND 77 AND IFZ DROP #1 ENDIF
 IFZ  ;if no change
  112 GET CASE
  = 0 -1 -1
  = 1 -1 #0
  = 2 -1 #1
  = 3 #0 -1
  = 4 #0 #1
  = 5 #1 -1
  = 6 #1 #0
  = 7 #1 #1
  ENDCASE XYMOVE
 ELSE
  112 RND ROR ROR 7 AND PUT  ;select new direction  
 ENDIF
;rock #2
 @FROM 122 GET PUT @TO 123 GET PUT
 #0  ;change-dir flag
 RND 77 AND IFZ DROP #1 ENDIF
 IFZ  ;if no change
  113 GET CASE
  = 0 -1 -1
  = 1 -1 #0
  = 2 -1 #1
  = 3 #0 -1
  = 4 #0 #1
  = 5 #1 -1
  = 6 #1 #0
  = 7 #1 #1
  ENDCASE XYMOVE
 ELSE
  113 RND ROR ROR 7 AND PUT  ;select new direction  
 ENDIF
;rock #3
 @FROM 124 GET PUT @TO 125 GET PUT
 #0  ;change-dir flag
 RND 77 AND IFZ DROP #1 ENDIF
 IFZ  ;if no change
  114 GET CASE
  = 0 -1 -1
  = 1 -1 #0
  = 2 -1 #1
  = 3 #0 -1
  = 4 #0 #1
  = 5 #1 -1
  = 6 #1 #0
  = 7 #1 #1
  ENDCASE XYMOVE
 ELSE
  114 RND ROR ROR 7 AND PUT  ;select new direction  
 ENDIF
; counter mod...
 DEC  ;decrement counter
 DUP S>SR ;copy to switch register
 DUP  ;dup counter to test
WHILE ;keep looping while not zero
DROP  ;counter
END
;----------------------------------------------------------
"Done" $PRINT CONSOLE