%%HP: T(3)A(D)F(.);
"TITLE Graphics Library

xROMID 1706
xTITLE GLIB :0.7
xCONFIG GLIBCFG

EXTERNAL xGRPIXON
EXTERNAL xGRPIXOFF
EXTERNAL xGRPIX?
EXTERNAL xGRLINE
EXTERNAL xGRBOX
EXTERNAL xGRCIRCLE
EXTERNAL xAPIXON
EXTERNAL xAPIXOFF
EXTERNAL xAPIX?
EXTERNAL xALINE
EXTERNAL xABOX
EXTERNAL xACIRCLE
EXTERNAL xGLINE
EXTERNAL xGBOX
EXTERNAL xGCIRCLE

STITLE GLIBCFG
LABEL GLIBCFG
::
 1706 TOSRRP
;

NIBB 1 8
STITLE GRPIXON
xNAME GRPIXON
::
  CK2&Dispatch
  #C5
  ::
    ZEROSWAP SPIXON
  ;
;

NIBB 1 8
STITLE GRPIXOFF
xNAME GRPIXOFF
::
  CK2&Dispatch
  #C5
  ::
    ONESWAP SPIXON
  ;
;

NIBB 1 8
STITLE GRPIX?
xNAME GRPIX?
::
  CK2&Dispatch
  #C5
  ::
    TWO SWAP
    SPIXON COERCEFLAG
  ;
;

NIBB 1 8
STITLE GRLINE
xNAME GRLINE
::
  CK3&Dispatch
  #C55
  SLINE
;

NIBB 1 8
STITLE GRBOX
xNAME GRBOX
::
  CK3&Dispatch
  #C55
  SBOX
;

NIBB 1 8
STITLE GRCIRCLE
xNAME GRCIRCLE
::
  CK3&Dispatch
  #C5B
  SCIRCLE
;

NIBB 1 8
STITLE APIXON
xNAME APIXON
::
  CK1&Dispatch
  list
  ::
    ABUFF ZERO ROT
    SPIXON DROP
  ;
;

NIBB 1 8
STITLE APIXOFF
xNAME APIXOFF
::
  CK1&Dispatch
  list
  ::
    ABUFF ONE ROT
    SPIXON DROP
  ;
;

NIBB 1 8
STITLE APIX?
xNAME APIX?
::
  CK1&Dispatch
  list
  ::
    ABUFF TWO ROT
    SPIXON
    SWAPDROP COERCEFLAG
  ;
;

NIBB 1 8
STITLE ALINE
xNAME ALINE
::
  CK2&Dispatch
  2LIST
  ::
    ABUFF UNROT SLINE DROP
  ;
;

NIBB 1 8
STITLE ABOX
xNAME ABOX
::
  CK2&Dispatch
  2LIST
  ::
    ABUFF UNROT SBOX DROP
  ;
;

NIBB 1 8
STITLE ACIRCLE
xNAME ACIRCLE
::
  CK2&Dispatch
  #5B
  ::
    ABUFF UNROT SCIRCLE DROP
  ;
;

NIBB 1 8
STITLE GLINE
xNAME GLINE
::
  CK2&Dispatch
  2LIST
  ::
    GBUFF UNROT SLINE DROP
  ;
;

NIBB 1 8
STITLE GBOX
xNAME GBOX
::
  CK2&Dispatch
  2LIST
  ::
    GBUFF UNROT SBOX DROP
  ;
;

NIBB 1 8
STITLE GCIRCLE
xNAME GCIRCLE
::
  CK2&Dispatch
  #5B
  ::
    GBUFF UNROT SCIRCLE DROP
  ;
;

* SBOX	V3
*
* Draws a box in the specified grob,
* using the specified coordinates.
*
* grob {#x1 #y1} {#x2 #y2}	->	grob
*
* Improvements over V2 (in BPIXONG) by Werner Huysegoms.

STITLE SBOX
NULLNAME SBOX
::
    2HXSLIST?
    ROT
    2HXSLIST?
    CODE
	GOSBVL	=POP2#	* POP THE START COORDINATES
	R1=C		* R1 = Y1
	R2=A		* R2 = X1
	GOSBVL	=POP2#	* POP THE END COORDINATES
	R3=C		* R3 = Y2
	R4=A		* R4 = X2
	A=0	W
	A=DAT1	A	* GET GROB ADDRESS
	GOSBVL	=SAVPTR * LEAVE GROB ON STACK FOR USER
	D1=A		* PUT GROB ADDRESS INTO D1
	C=R2		* C = X1
	A=R4		* A = X2
	?A>C	A	* IF X2>X1 THEN LEAVE AS IS
	GOYES	BXK
	R2=A		* ELSE SWAP X1 & X2
	R4=C
BXK	C=R1		* C = Y1
	A=R3		* A = Y2
	?A>C	A	* IF Y2>Y1 THEN LEAVE AS IS
	GOYES	BYK
	R1=A		* ELSE SWAP Y1 & Y2
	R3=C
BYK	C=R1
	R0=C		* R0 = Y1..Y2
VLOOP	A=R2		* A = X1
	C=R0		* C = YN
	GOSUB	BPIXONG
	A=R4		* A = X2
	C=R0		* C = YN
	GOSUB	BPIXONG
	A=R0
	A=A+1	A	* INCREMENT YN
	R0=A
	C=R3		* C = Y2
	?A<=C	A	* IF YN <= Y2
	GOYES	VLOOP	*  THEN GO AROUND LOOP
	C=R2
	R0=C		* R0 = X1..X2
HLOOP	A=R0		* A = XN
	C=R1		* C = Y1
	GOSUB	BPIXONG
	A=R0		* A = XN
	C=R3		* C = Y2
	GOSUB	BPIXONG
	A=R0
	A=A+1	A	* INCREMENT XN
	R0=A
	C=R4		* C = X2
	?A<C	A	* IF XN < X2
	GOYES	HLOOP	*  THEN GO AROUND LOOP
	GOVLNG	=GETPTRLOOP
*
*
* Draw a single pixel
*
BPIXONG	B=A     A
        D1=D1+  10
        A=DAT1  A
	D1=D1+  5
        ?C<A    A               ( y out of grob ? )
        GOYES   BYOK
BBOUNDS	D1=D1-	15		* POINT D1 BACK AT GROB
	RTN
*
BYOK    A=DAT1  A
        ?B>=A   A               ( x out of grob ? )
        GOYES   BBOUNDS

        D1=D1+  5               ( D1 -> grob body )
        GOSBVL  =w->W           ( pixel width -> nibble Width )
        D=C     A
        C=B     A
        CDEX    A
        GOSBVL  =MUL#           ( Ba := Aa * Ca )

*--- determine mask -----
* *magic* trick from Detlef Mueller, improved by me
* the goal is to have Cs contain 1, 2, 4 or 8 when x % 4 equals
* 0, 1, 2 or 3 respectively
* It makes use of the fact that LCHEX
* - loads least significant nibble first
* - starts loading at the Pth nibble (0..15)
* - wraps from the 15th nibble round to the 0th if all nibbles have not
*   been loaded yet
*
        LCHEX   C               ( 1100b )
        C=C!D   P               ( C.0 contains 12,13,14 or 15 )
        P=C     0
        LCHEX   1248            ( Cs now contains mask )
        P=      0

        D=D+D   A               ( x DIV 4 )
        D=D+D   A
        DSR     A

        C=D1			* COPY D1 INTO C
        C=C+B   A               ( add offset  )
        C=C+D   A               ( add x DIV 4 )
        CD1EX			* ADDR TO CHANGE IN D1, Ca->GROB BODY

        A=DAT1  S
        A=A!C   S               ( set pixel )
        DAT1=A  S

	D1=C			* POINT D1 BACK TO START OF GROB BODY
	D1=D1-	10		* NOW MOVE BACK TO GROB START
	D1=D1-	10
	RTN
*
    ENDCODE
;

* SPIXON	V7
*
* Single pixel routine can turn pixel on, off
* or test its value.
*
* grob #0 {#x #y} -> grob with pixel turned on
* grob #1 {#x #y} -> grob with pixel turned off
* grob #2 {#x #y} -> grob pixel_value (0/1)
*
* Improvements over V6 by Werner Huysegoms (and Detlef Mueller)
* make this about 1% faster but more importantly 45.5 bytes shorter.
* Note that this routine now uses A,B,C and D (instead of A,B,C,R0).

STITLE SPIXON
NULLNAME SPIXON
::
    2HXSLIST?

    CODE

	GOSBVL	=POP2#	* POP THE COORDINATES
	CR0EX		* SAVE X & Y
	AR1EX
	GOSBVL	=POP#	* GET MODE VALUE
	C=A	A	* AND STORE IT
	ST=C		* IN STATUS REGISTER
	A=DAT1	A	* GET GROB ADDRESS
	GOSBVL	=SAVPTR * LEAVE GROB ON STACK FOR USER
	D1=A		* PUT GROB ADDRESS INTO D1
	CR0EX		* RECOVER X & Y
	AR1EX		* Aa: x, Ca: y, D1: ->grob

* This is where the real pixon/off/test subroutine starts

        B=A     A
        D1=D1+  10
        A=DAT1  A
        ?C<A   A               ( y out of grob ? )
        GOYES   PYOK
PBOUNDS	?ST=1	1		* IF PIXEL TEST RETURN FALSE
	GOYES	TPIX?F
	GOVLNG	=GETPTRLOOP	* ELSE JUST EXIT

PYOK    D1=D1+  5
        A=DAT1  A
        ?B>=A   A                ( x out of grob ? )
        GOYES   PBOUNDS

        D1=D1+  5               ( D1 -> grob body )
        GOSBVL  =w->W           ( pixel width -> nibble Width )
        D=C     A
        C=B     A
        CDEX    A
        GOSBVL  =MUL#           ( Ba := Aa * Ca )

*--- determine mask -----
* *magic* trick from Detlef Mueller, improved by Werner
* the goal is to have Cs contain 1, 2, 4 or 8 when x % 4 equals
* 0, 1, 2 or 3 respectively
* It makes use of the fact that LCHEX
* - loads least significant nibble first
* - starts loading at the Pth nibble (0..15)
* - wraps from the 15th nibble round to the 0th if all nibbles have not
*   been loaded yet
*
        LCHEX   C               ( 1100b )
        C=C!D   P               ( C.0 contains 12,13,14 or 15 )
        P=C     0
        LCHEX   1248            ( Cs now contains mask )
        P=      0

        D=D+D   A               ( x DIV 4 )
        D=D+D   A
        DSR     A

        CD1EX
        C=C+B   A               ( add offset  )
        C=C+D   A               ( add x DIV 4 )
        D1=C

        A=DAT1  S

	?ST=1	0		* ST=1 MEANS...
	GOYES	TPIXOFF		* TURN PIXEL OFF
	?ST=1	1		* ST=2 MEANS...
	GOYES	TPIX?		* TEST PIXEL VALUE
TPIXON	A=A!C	S		* NEW = OLD OR MASK
TWAYOUT	DAT1=A	S		* WRITE NEW PIXEL INTO GROB
	GOVLNG	=GETPTRLOOP	* RESTORE RPL REGISTERS
TPIX?F	GOVLNG	=GPPushFLoop	* RETURN FALSE
TPIXOFF	C=-C-1	S		* NEGATE MASK
	A=A&C	S		* AND MASK WITH EXISTING VALUE
	GOTO	TWAYOUT
TPIX?	A=A&C	S		* MASK AND EXISTING VALUE
	?A=0	S		* CHECK IF BIT SET
	GOYES	TPIX?F
	GOVLNG	=GPPushTLoop	* RETURN TRUE

    ENDCODE
;

* SLINE	V1	311.5 bytes #9661h
*
* Draws a line in the specified grob,
* between the specified coordinates.
*
* grob {#x1 #y1} {#x2 #y2}	->	grob
*

STITLE SLINE
NULLNAME SLINE
::
    2HXSLIST?
    ROT
    2HXSLIST?
    CODE
	GOSBVL	=POP2#	* POP THE START COORDINATES
	R1=C		* R1 = Y1
	R2=A		* R2 = X1
	GOSBVL	=POP2#	* POP THE END COORDINATES
	R3=C		* R3 = Y2
	R4=A		* R4 = X2
	A=0	W
	A=DAT1	A	* GET GROB ADDRESS
	GOSBVL	=SAVPTR * LEAVE GROB ON STACK FOR USER
	D1=A		* PUT GROB ADDRESS INTO D1

	ST=0	0
	A=R2		* A = X1
	C=R4		* C = X2
	C=C-A	A	* C = DX = X2-X1
	GONC	DONESX	* IF DX IS +VE, SX FLAG = 0
	ST=1	0	* SET SX FLAG IF DX IS -VE
	C=-C	A	* C IS NOW +VE I.E. ABS(DX)
DONESX	C=C+C	A	* AX = ABS(DX)*2
	B=C	A	* B = AX

	ST=0	1
	A=R1		* A = Y1
	C=R3		* C = Y2
	C=C-A	A	* C = DY = Y2-Y1
	GONC	DONESY	* IF DY IS +VE, SY FLAG = 0
	ST=1	1	* SET SY FLAG IY DY IS -VE
	C=-C	A	* C IS NOW +VE I.E. ABS(DY)
DONESY	C=C+C	A	* C = AY = ABS(DY)*2

	?B>C	A	* IF AX > AY THEN X DOMINANT
	GOYES	XDOM
	GOTO	YDOM
*
* X DOMINANT
*
* B=AX		C=AY		D1=GROB
* R4=X2		R3=Y2
* R2=X1		R1=Y1

XDOM	R3=C		* PUT AY INTO CORRECT REG
	CBEX	A	* R3=B=AY, C=AX
	CR4EX		* R4=AX, C=X2, R3=B=AY
	R0=C		* R3=AY, R4=AX, R0=X2, B=AY
	C=R4		* R3=AY, R4=AX, R0=X2, B=AY, C=AX
	CSRB.F	A	* C=AX/2
	B=B-C	A	* B=AY-(AX/2)
	C=B	A	* C=AY-(AX/2)
	D0=C		* D0=AY-(AX/2)

XLOOP	A=R2
	C=R1
	GOSUB	LPIXONG
	C=R2		* C=X
	A=R0		* A=X2
	?C#A	A
	GOYES	XCONT
	GOVLNG	=GETPTRLOOP
*
XCONT	C=D0		* C=D
	C=C+C	A
	GOC	XDNEG	* SKIP IF D -VE

	C=R1
	?ST=1	1
	GOYES	XCDECY
	C=C+1	A
	GOTO	XCONT2
XCDECY	C=C-1	A
XCONT2	R1=C		* Y=Y+SY

	C=D0
	A=R4
	C=C-A	A
	D0=C		* D=D-AX

XDNEG	C=D0
	A=R3
	C=C+A	A
	D0=C		* D=D+AY

	C=R2
	?ST=1	0
	GOYES	XCONT3
	C=C+1	A
	GOTO	XCONT4
XCONT3	C=C-1	A
XCONT4	R2=C
	GOTO	XLOOP	* X=X+SX
*
*
* Y DOMINANT
*
* B=AX		C=AY		D1=GROB
* R4=X2		R3=Y2
* R2=X1		R1=Y1

YDOM	A=R3		* A=Y2, C=AY
	ACEX	A	* C=Y2, A=AY
	R0=C		* R0=Y2
	R3=A		* R3=A=AY
	C=B	A	* B=C=AX
	R4=C		* R4=B=C=AX, R3=A=AY
	ASRB.F	A	* A=AY/2
	C=C-A	A	* C=AX-(AY/2)
	D0=C		* D0=AX-(AY/2)

YLOOP	A=R2
	C=R1
	GOSUB	LPIXONG
	C=R1		* C=Y
	A=R0		* D=Y2
	?C#A	A
	GOYES	YCONT
	GOVLNG	=GETPTRLOOP
*
YCONT	C=D0
	C=C+C	A
	GOC	YDNEG	* SKIP IF D -VE

	C=R2
	?ST=1	0
	GOYES	YCDECX
	C=C+1	A
	GOTO	YCONT2
YCDECX	C=C-1	A
YCONT2	R2=C		* X=X+SX

	C=D0
	A=R3
	C=C-A	A
	D0=C		* D=D-AY

YDNEG	C=D0
	A=R4
	C=C+A	A
	D0=C		* D=D+AX

	C=R1
	?ST=1	1
	GOYES	YCONT3
	C=C+1	A
	GOTO	YCONT4
YCONT3	C=C-1	A
YCONT4	R1=C
	GOTO	YLOOP
*
*
* Draw a single pixel
*
LPIXONG	B=A     A
        D1=D1+  10
        A=DAT1  A
	D1=D1+  5
        ?C<A    A               ( y out of grob ? )
        GOYES   LYOK
LBOUNDS	D1=D1-	15		* POINT D1 BACK AT GROB
	RTN
*
LYOK    A=DAT1  A
        ?B>=A   A               ( x out of grob ? )
        GOYES   LBOUNDS

        D1=D1+  5               ( D1 -> grob body )
        GOSBVL  =w->W           ( pixel width -> nibble Width )
        D=C     A
        C=B     A
        CDEX    A
        GOSBVL  =MUL#           ( Ba := Aa * Ca )

*--- determine mask -----
* *magic* trick from Detlef Mueller, improved by me
* the goal is to have Cs contain 1, 2, 4 or 8 when x % 4 equals
* 0, 1, 2 or 3 respectively
* It makes use of the fact that LCHEX
* - loads least significant nibble first
* - starts loading at the Pth nibble (0..15)
* - wraps from the 15th nibble round to the 0th if all nibbles have not
*   been loaded yet
*
        LCHEX   C               ( 1100b )
        C=C!D   P               ( C.0 contains 12,13,14 or 15 )
        P=C     0
        LCHEX   1248            ( Cs now contains mask )
        P=      0

        D=D+D   A               ( x DIV 4 )
        D=D+D   A
        DSR     A

        C=D1			* COPY D1 INTO C
        C=C+B   A               ( add offset  )
        C=C+D   A               ( add x DIV 4 )
        CD1EX			* ADDR TO CHANGE IN D1, Ca->GROB BODY

        A=DAT1  S
        A=A!C   S               ( set pixel )
        DAT1=A  S

	D1=C			* POINT D1 BACK TO START OF GROB BODY
	D1=D1-	10		* NOW MOVE BACK TO GROB START
	D1=D1-	10
	RTN
*
    ENDCODE
;

* SCIRCLE	V6
*
* Draws a circle in the specified grob,
* centred at the specified origin, with
* the specified radius.
*
* grob {#x0 #y0} #radius	->	grob
*
* V6 Optimisation by MP save 16 bytes.
* V5 Improvements over V4 (in CPIXONG) by Werner Huysegoms.

STITLE SCIRCLE
NULLNAME SCIRCLE
::
    HXS>#
    SWAP
    2HXSLIST?
    CODE
	GOSBVL	=POP2#	* POP THE ORIGIN COORDINATES
	R3=C		* SAVE X0 & Y0
	R4=A
	GOSBVL	=POP#	* POP THE PIXEL COORDINATES
	R1=A		* R1 = Y PIXEL (STARTS = RADIUS)
	A=DAT1	A	* GET GROB ADDRESS
	GOSBVL	=SAVPTR * LEAVE GROB ON STACK FOR USER
	D1=A		* PUT GROB ADDRESS INTO D1
	C=0	A	* X PIXEL STARTS AT 0
	R2=C		* R2 = X PIXEL
	A=R1		* A = RADIUS
	A=A+A	A	* A = 2*RADIUS
	LC(1)	3
	C=C-A	A	* C = 3-2*RADIUS
	D0=C		* D0 = 3-2*RADIUS

	C=R2		* C = X PIXEL
MLOOP	A=R1		* A = Y PIXEL
	?C<A	A	* IF X<Y
	GOYES	INWHILE
	?C#A	A
	GOYES	MFIN
	GOSUB	DRAW8
MFIN	GOVLNG	=GETPTRLOOP
*
INWHILE	GOSUB	DRAW8
	C=R2		* C = X
	A=D0
	A=A+A	A	* MULTIPLY D*2 SO CARRY SET IF D<0
	GONC	DPOS
	A=D0
	C=C+C	A
	C=C+C	A	* C = 4*X
	C=C+A	A	* C = D+4*X
	C=C+CON	A,6	* C = D+4*X+6
	D0=C		* STORE NEW D
INCAL	C=R2
	C=C+1	A
	R2=C		* X=X+1
	GOTO	MLOOP
*
DPOS	A=R1		* A = Y
	C=C-A	A	* C = X-Y
	C=C+C	A	* C = 2*(X-Y)
	C=C+C	A	* C = 4*(X-Y)
	C=C+CON	A,10	* C = 4*(X-Y)+10
	A=D0
	C=C+A	A	* C = D+4*(X-Y)+10
	D0=C		* STORE NEW D
	A=R1
	A=A-1	A	* Y=Y-1
	R1=A		* STORE NEW Y
	GOTO	INCAL
*
* Draw 8 pixels subroutine
*
DRAW8	ST=1	0	* SET BIT 0

DLOOP	C=R3
	A=R2
	C=C+A	A
	A=R1
	B=A	A
	A=R4
	A=A+B	A
	GOSUB	CPIXONG	* TURN ON (X0+X,Y0+Y)

	C=R3
	A=R2
	C=C-A	A
	A=R1
	B=A	A
	A=R4
	A=A-B	A
	GOSUB	CPIXONG	* TURN ON (X0-X,Y0-Y)

	C=R3
	A=R2
	C=C+A	A
	A=R1
	B=A	A
	A=R4
	A=A-B	A
	GOSUB	CPIXONG	* TURN ON (X0+X,Y0-Y)

	C=R3
	A=R2
	C=C-A	A
	A=R1
	B=A	A
	A=R4
	A=A+B	A
	GOSUB	CPIXONG	* TURN ON (X0-X,Y0+Y)

	A=R1		* SWAP X AND Y
	AR2EX
	R1=A

	?ST=0	0	* ALL OF ABOVE IS DONE TWICE
	RTNYES		* ALL DONE
	ST=0	0	* CLEAR STATUS BIT 0 2ND TIME ROUND LOOP
	GOTO	DLOOP
*
* Draw a single pixel
*
CPIXONG	B=A     A
        D1=D1+  10
        A=DAT1  A
	D1=D1+  5
        ?C<A    A               ( y out of grob ? )
        GOYES   CYOK
CBOUNDS	D1=D1-	15		* POINT D1 BACK AT GROB
	RTN
*
CYOK    A=DAT1  A
        ?B>=A   A               ( x out of grob ? )
        GOYES   CBOUNDS

        D1=D1+  5               ( D1 -> grob body )
        GOSBVL  =w->W           ( pixel width -> nibble Width )
        D=C     A
        C=B     A
        CDEX    A
        GOSBVL  =MUL#           ( Ba := Aa * Ca )

*--- determine mask -----
* *magic* trick from Detlef Mueller, improved by me
* the goal is to have Cs contain 1, 2, 4 or 8 when x % 4 equals
* 0, 1, 2 or 3 respectively
* It makes use of the fact that LCHEX
* - loads least significant nibble first
* - starts loading at the Pth nibble (0..15)
* - wraps from the 15th nibble round to the 0th if all nibbles have not
*   been loaded yet
*
        LCHEX   C               ( 1100b )
        C=C!D   P               ( C.0 contains 12,13,14 or 15 )
        P=C     0
        LCHEX   1248            ( Cs now contains mask )
        P=      0

        D=D+D   A               ( x DIV 4 )
        D=D+D   A
        DSR     A

        C=D1			* COPY D1 INTO C
        C=C+B   A               ( add offset  )
        C=C+D   A               ( add x DIV 4 )
        CD1EX			* ADDR TO CHANGE IN D1, Ca->GROB BODY

        A=DAT1  S
        A=A!C   S               ( set pixel )
        DAT1=A  S

	D1=C			* POINT D1 BACK TO START OF GROB BODY
	D1=D1-	10		* NOW MOVE BACK TO GROB START
	D1=D1-	10
	RTN
*
    ENDCODE
;


"