xref  graphicsbase
   xref  rastport
   xref  viewport
   xref  type_mismatch
   xref  msg
   xref  reinterp

   xref  ipop
   xref  r.ipush
   xref  popnum
   xref  dictsearch

   xref  popxy,poprxy
   xref  _showg,_scaleg,_lengthg
   xref  xadvance

   xref  checklwidth,xywidth

   section  one

   include  "ps.h"


   lref     ClearScreen,4
   lref     TextLength,5
   lref     Text,6
   lref     SetFont,7
   lref     OpenFont,8
   lref     CloseFont,9
   lref     Move,36
   lref     Draw,37
   lref     AreaMove,38
   lref     AreaDraw,39
   lref     AreaEnd,40
   lref     InitArea,43
   lref     SetRGB4,44
   lref     RectFill,47
   lref     WritePixel,50
   lref     Flood,51
   lref     SetAPen,53
   lref     SetBPen,54
   lref     SetDrMd,55
   lref     InitTmpRas,74
   lref     AllocRaster,78
   lref     FreeRaster,79
   lref     GetRGB4,93


graphics macro
      move.l   A6,-(SP)
      move.l   graphicsbase,A6
      move.l   rastport,A1
      jsr      _LVO\1(A6)
      move.l   (SP)+,A6
      endm

graph   macro
      move.l   A6,-(SP)
      move.l   graphicsbase,A6
      jsr      _LVO\1(A6)
      move.l   (SP)+,A6
      endm



   xref     mathffpbase


math  macro
      move.l   A6,-(SP)
      move.l   mathffpbase,A6
      jsr      _LVO\1(A6)
      move.l   (SP)+,A6
      endm

mathb macro
      move.l   mathffpbase,A6
      endm

maths macro
      jsr      _LVO\1(A6)
      endm

   lref     SPFix,1
   lref     SPFlt,2
   lref     SPCmp,3
   lref     SPTst,4
   lref     SPAbs,5
   lref     SPNeg,6
   lref     SPAdd,7
   lref     SPSub,8
   lref     SPMul,9
   lref     SPDiv,10

AreaSize    equ   500

PenMask     equ   NumColors-1
   ifne     HiRes
MaxY        equ   399
   endc
   ifeq     HiRes
MaxY        equ   199
   endc

*************************

   xdef  initgr
initgr
   move.l   rastport,A1

   move.l   #640,D0
   move.l   #MaxY+1,D1
   move.l   A1,-(SP)
   graph    AllocRaster
   move.l   D0,rasterpt

   move.l   (SP),A1
   lea      tmpras,A0
   move.l   A0,$0C(A1)
   move.l   D0,A1
   move.l   #640*(MaxY+1),D0
   graph    InitTmpRas

   move.l   (SP)+,A1
   lea      areasptrn,A0
   move.l   A0,$08(A1)
   move.b   #2,$1D(A1)     4 words

   lea      areainfo,A0
   move.l   A0,$10(A1)
   lea      areabuffer,A1
   move.l   #AreaSize,D0
   graph    InitArea

   lea      pstacktop,A0
   move.l   A0,pstack
   clr.w    pstackcnt
   clr.w    (A0)+
   lea      pathbuffer,A1
   move.l   A1,(A0)
   clr.w    pointcnt
   move.l   A1,nextpoint

   moveq    #1,D0
   graphics SetAPen
   moveq    #0,D0
   graphics SetBPen
   moveq    #1,D0
   graphics SetDrMd

   rts


   xdef  endgr
endgr
   move.l   rasterpt,A0
   move.l   #640,D0
   move.l   #MaxY+1,D1
   graphics FreeRaster
   move.l   rastport,A1
   clr.l   $08(A1)
   clr.l   $0C(A1)
   clr.l   $10(A1)
   rts

rasterpt    dc.l  0



  DEF    stringwidth
   move.b   resfontflag,D0
   bne      _lengthg
  ARG    String
   move.l   D0,A0
   moveq    #0,D0
   move.w   (A0)+,D0
   graphics TextLength
   math     SPFlt       dx
   move.w   #Real,D2
   bsr      r.ipush
   moveq    #0,D0       dy = 0
   bra      r.ipush


  DEF    show
  ARG    String
   move.l   D0,-(SP)
   bsr      movehere
   move.l   (SP)+,D0

   move.l   D0,A0
   move.b   resfontflag,D0
   bne      showresfont

   movem.l  currdevpoint,D0/D1
   graphics Move

   move.l   rastport,A1
   move.w   $24(A1),-(SP)
   moveq    #0,D0
   move.w   (A0)+,D0
   graphics Text
   move.l   rastport,A1
   moveq    #0,D0
   move.w   $24(A1),D0
   move.w   (SP)+,D1
   sub.w    D1,D0
   bsr      xadvance
   movem.l  D0-D3,bpath
   movem.l  D0-D3,currdevpoint
   rts

showresfont
   move.l   A0,D0
   move.w   #String,D2
   bsr      r.ipush
   bra      _showg

newpoint
   moveq    #0,D4
   move.w   #MaxY,D4
   cmp.l    D4,D1
   ble      1$
   move.l   D4,D1
1$ tst.l    D1
   bpl      2$
   clr.l    D1
2$ move.w   #639,D4
   cmp.l    D4,D0
   ble      3$
   move.l   D4,D0
3$ tst.l    D0
   bpl      4$
   clr.l    D0
4$ rts

  DEF    newpath
   move.l   pstack,A0
   move.w   (A0)+,pointcnt
   move.l   (A0),nextpoint
   move.b   #0,strokepathflag
   rts

   xdef     ggsave
ggsave
   lea      pstackcnt,A0
   cmp.w    #PstackSize,(A0)
   beq      1$
   addq.w   #1,(A0)
   move.l   pstack,A0
   move.l   currfont,-(A0)
   move.l   graylevel,-(A0)
   move.l   linecap,-(A0)
   move.l   nextpoint,-(A0)   must be pushed next last
   move.w   pointcnt,-(A0)    must be pushed last
   move.l   A0,pstack
   rts
1$ ERR      psov

   xdef     ggrestore
ggrestore
   lea      pstackcnt,A0
   tst.w    (A0)
   beq      1$
   subq.w   #1,(A0)
   move.l   pstack,A0
   move.w   (A0)+,pointcnt
   move.l   (A0)+,nextpoint
   move.l   (A0)+,linecap
   move.l   (A0)+,D0
   move.l   (A0)+,currfont
   move.l   A0,pstack
   bsr      resetgray
   move.l   currfont,D0
   bra      resetfont
1$ ERR      psuv



c_moveto    equ   1
c_lineto    equ   2
c_closepath equ   3

appendpoint
   lea      pointcnt,A0
   cmp.w    #AreaSize,(A0)
   beq      pointprob
   addq.w   #1,(A0)
   move.l   nextpoint,A0
   move.w   D0,(A0)+
   move.l   D2,(A0)+
   move.l   D3,(A0)+
   move.l   A0,nextpoint
   rts
pointprob
   ERR      pntsov

  DEF    rmoveto
   bsr      poprxy
   bra      ymoveto

  DEF    moveto
   bsr      popxy
   xdef  ymoveto
ymoveto
   movem.l  D0-D3,bpath
   movem.l  D0-D3,currdevpoint
   moveq    #c_moveto,D0
   bra      appendpoint

movehere
   movem.l  currdevpoint,D0-D3

   xdef  xmoveto
xmoveto
   bsr      newpoint
   movem.l  D0-D3,bpath
   movem.l  D0-D3,currdevpoint
   graphics Move
   rts

  DEF    rlineto
   bsr      poprxy
   bra      ylineto


  DEF    lineto
   bsr      popxy
   xdef  ylineto
ylineto
   tst.w    pointcnt
   bne      1$
   movem.l  D0-D3,-(SP)
   movem.l  currdevpoint,D0-D3
   bsr      ymoveto
   movem.l  (SP)+,D0-D3
1$
   movem.l  D0-D3,currdevpoint
   moveq    #c_lineto,D0
   bra      appendpoint

   xdef     xclosepath
xclosepath
   movem.l  bpath,D0-D3
   movem.l  D0-D3,currdevpoint

   xdef  xlineto
xlineto
   bsr      arlineto
   beq      xxlineto
   rts
xxlineto
   bsr      newpoint
   graphics Draw
   rts

  DEF    closepath
   movem.l  bpath,D0-D3
   movem.l  D0-D3,currdevpoint
   moveq    #c_closepath,D0
   bra      appendpoint


  DEF    pixel
*   graphics WritePixel
*   rts
   bsr      movehere
   move.l   rastport,A1
   move.l   4(A1),A0       A0 -> bitmap
   move.w   $26(A1),D1      D1 = cp_y
   mulu     (A0),D1        cp_y * bytes per row
   moveq    #0,D0
   move.w   $24(A1),D0      cp_x
   move.l   D0,D2
   lsr.l    #3,D0          byte offset for x
   add.l    D0,D1          byte address of pixel
   and.l    #7,D2          bit offset
   moveq    #7,D0
   sub      D2,D0
   move.b   $19(A1),D3     pen color

   move.l   8(A0),A1       base address of first screen
   btst     #0,D3
   beq      1$
   bsr      2$
1$ move.l   12(A0),A1      base address of second screen
   btst     #1,D3
   beq      3$
2$ add.l    D1,A1
   bset     D0,(A1)
3$ rts

**debug
   ifd   DEBUG2
pushA0
   movem.l  D0-D7/A1-A6,-(SP)
   move.l   A0,D0
   move.w   #Integer,D2
   bsr      r.ipush
   movem.l  (SP)+,D0-D7/A1-A6
   rts
   endc

xpixel
**debug
   ifd   DEBUG2
   move.l   D0,A0
   bsr      pushA0
   move.l   D1,A0
   bsr      pushA0
   move.l   D2,A0
   bsr      pushA0
   endc

   tst.b    D2
   beq      3$
   tst.l    D1
   bmi      3$
   tst.l    D0
   bmi      3$
   cmp.l    #639,D0
   bhi      3$
   cmp.l    #MaxY,D1
   bhi      3$

   mulu     (A5),D1        cp_y * bytes per row
   move.l   D2,A1          save pencolor
   move.l   D0,D2
   lsr.l    #3,D0          byte offset for x
   add.l    D0,D1          byte address of pixel
   and.l    #7,D2          bit offset
   moveq    #7,D0
   sub      D2,D0
   move.l   A1,D2          pen color

   move.l   8(A5),A1       base address of first screen
   btst     #0,D2
   beq      1$
   bsr      2$
1$ move.l   12(A5),A1      base address of second screen
   btst     #1,D2

   ifne     HiRes
   beq      10$
   bsr      2$
10$
   move.l   16(A5),A1
   btst     #2,D2
   endc

   beq      3$
2$ add.l    D1,A1
   bset     D0,(A1)
3$ rts



arlineto
   movem.l  oldx,A0/A1     starting real coord
   movem.l  D2/D3,oldx     ending real coord - save for next time
   tst.l    vint
   beq      900$           0 vint means use Amiga line drawer
* now draw antirasterized line from (A0,A1) to (D2,D3)
* (y-axis is still inverted)
   movem.l  D5-D7/A2-A6,-(SP)
* D2,D3,A0,A1,A6
   move.l   A0,D4
   move.l   A1,D5
* update cp
   graphics Move
* set A6 for short math calls
   mathb

* D2(ex),D3(ey),D4(sx),D5(sy),A6(mbase)

   move.l   D5,D0
   move.l   D3,D1
   maths    SPCmp
   bcs      4$
   exg      D2,D4
   exg      D3,D5
4$

   move.l   D2,D0
   move.l   D4,D1
   maths    SPSub          ex - sx
   move.l   D0,D6

   move.l   D3,D0
   move.l   D5,D1
   maths    SPSub          ey - sy
   move.l   D0,D7

* D2(ex),D3(ey),D4(sx),D5(sy),D6(dx),D7(dy)

*  move.l   D7,D0
   and.b    #$7F,D0
   move.l   D6,D1
   and.b    #$7F,D1
   maths    SPCmp          if abs(dy) >= abs(dx), exchange
   bcs      10$
   exg      D2,D3
   exg      D4,D5
   exg      D6,D7
   moveq    #-1,D3         set exchange flag
   bra      11$
10$
   moveq    #0,D3
11$

   move.l   D4,D0
   move.l   #PointFive,D1
   maths    SPAdd
   maths    SPFix
   move.l   D0,A2          A2 = rx = round(sx)
* D2(ex),D3(flag),D4(sx),D5(sy),D6(dx),D7(dy)
* A2(rx),A4(abs dx)



*  move.l   A2,D0    count = trunc(abs(ex - rx)) + 1
   maths    SPFlt
   move.l   D0,D1
   move.l   D2,D0
   maths    SPSub    ex - flt(rx)
   and.b    #$7F,D0
* round not in original
   move.l   #PointFive,D1
   maths    SPAdd
   maths    SPFix
   addq.l   #1,D0
   move.l   D0,A4

   move.l   D3,D2    move flag

   move.l   D7,D0
   move.l   D6,D1
   beq      800$
   maths    SPDiv
   move.l   D0,A5          A5 = slope = (ey - sy)/(ex - sx)
* D2(flag),D3(n.u.),D4(sx),D5(sy),D6(dx),D7(dy),A2(rx),A4(cnt),A5(slope),A6

   move.l   A2,D0
   maths    SPFlt
   move.l   D4,D1
   maths    SPSub          rx - sx
   move.l   A5,D1
   maths    SPMul          times slope
* abs ??
   move.l   D5,D1
   maths    SPAdd          plus sy
   move.l   D0,D3          D3 = aux

* round ??
   maths    SPFix
   move.l   D0,A3          A3 = ry

   move.l   A5,D0
   and.b    #$7F,D0
   move.l   vint,D5
   move.l   D5,D1
   maths    SPMul
   move.l   D0,D4          D4 = dint = abs(slope) * vint
* D2(flag),D3(aux),D4(dint),D5(vint),D6(dx),D7(dy)
* A2(rx),A3(ry),A4(cnt),A5(n.u.),A6

   move.l   A3,D0
   maths    SPFlt
   move.l   D0,D1
   move.l   D3,D0
   maths    SPSub          aux - ry
   move.l   D5,D1
   maths    SPMul          times vint
   move.l   D0,D3          D3 = lint
* D2(flag),D3(lint),D4(dint),D5(vint),D6(dx),D7(dy)
* A2(rx),A3(ry),A4(cnt),A5(n.u.),A6

   tst.w    D2
   bpl      20$
   exg      A2,A3
   exg      D6,D7
20$

   move.l   D6,D1          dx -> +-1
   moveq    #0,D0
   maths    SPCmp
   bne      22$
   moveq    #1,D0
22$
   move.l   D0,D6

*   move.l   D7,D0          dy -> -+1
*   moveq    #0,D1
*   maths    SPCmp
*   bne      24$
*   moveq    #-1,D0
*24$
*   move.l   D0,D7

   move.l   rastport,A0
   move.l   4(A0),A5       bitmap

   move.l   #MaxY,D0        uninvert y-axis
   move.l   A3,D1
   sub.l    D1,D0
   move.l   D0,A3


* D0 (pass x)
* D1 (pass y)
* D2 flag dy > dx and pass pencolor
* D3 lint
* D4 dint
* D5 vint
* D6 sign dx
*** D7 sign dy (n.u. now)
* A0
* A1 (temp)
* A2 rx
* A3 ry
* A4 cnt
* A5 bitmap
* A6 mathffpbase

**debug
   ifd   DEBUG1
   move.l   A4,SAVECNT
   move.l   A2,SAVERX
   move.l   A3,SAVERY
   move.l   D6,SAVESDX
   move.l   D7,SAVESDY
   move.l   D3,SAVELINT
   move.l   D4,SAVEDINT
   endc

100$
   subq.l   #1,A4
   move.l   A4,D0
   bmi      800$

   swap     D2       save exchange flag

   move.l   D5,D0
   move.l   D3,D1
   maths    SPSub       vint - lint
   bsr      pixreg

   bsr      xpixel      pixel(rx,ry,rint)

   move.l   D3,D0
   bsr      pixreg

   swap     D2
   tst.w    D2
   bpl      110$
   add.l    D6,D0       lx = rx + 1
   bra      111$
110$
*   add.l    D7,D1       ly = ry + 1
   subq.l   #1,D1
111$
   swap     D2

   bsr      xpixel      pixel(lx,ly,lint)

   swap     D2

   move.l   D3,D0
   move.l   D4,D1
   maths    SPAdd
   move.l   D0,D3       lint = lint + dint

   move.l   D5,D1
   maths    SPCmp
   bcs      200$        not if lint < vint

   tst.w    D2
   bmi      120$
*   add.l    D7,A3       ry = ry + sign(dy)
   subq.l   #1,A3
   bra      130$
120$
   add.l    D6,A2       rx = rx + sign(dx)
130$


   move.l   D3,D0
   move.l   D5,D1
   maths    SPSub
   move.l   D0,D3       lint = lint - vint

200$
   tst.w    D2
   bmi      220$
   add.l    D6,A2       rx = rx + 1
   bra      100$
220$
*   add.l    D7,A3
   subq.l   #1,A3
   bra      100$


800$
   movem.l  (SP)+,D5-D7/A2-A6

**debug
   ifd   DEBUG1
   move.w   #Integer,D2
   move.l   SAVECNT,D0
   bsr      r.ipush
   move.l   SAVERX,D0
   bsr      r.ipush
   move.l   SAVERY,D0
   bsr      r.ipush
   move.l   SAVESDX,D0
   bsr      r.ipush
   move.l   SAVESDY,D0
   bsr      r.ipush
   move.w   #Real,D2
   move.l   SAVELINT,D0
   bsr      r.ipush
   move.l   SAVEDINT,D0
   bsr      r.ipush
   endc

   moveq    #1,D0          signal line is drawn
900$
   rts

**debug
   ifd   DEBUG1
SAVECNT  dc.l  0
SAVERX   dc.l  0
SAVERY   dc.l  0
SAVESDX  dc.l  0
SAVESDY  dc.l  0
SAVELINT   dc.l   0
SAVEDINT   dc.l   0
   endc

pixreg
   move.l   #FourPoint,D1
   maths    SPMul
   maths    SPFix
   cmp.b    #4,D0
   bne      2$
   moveq    #3,D0
2$ move.w   D0,D2
   move.l   A2,D0
   move.l   A3,D1
*   tst.l    D7
*   bmi      1$
*   addq.l   #1,D1
1$ rts


  DEF    greyline
   bsr      pop01
   move.l   D0,vint
   rts

pop01
   bsr      ipop
   move.l   #OnePoint,D1
   cmp.w    #Real,D2
   beq      1$
   cmp.w    #Integer,D2
   bne      type_mismatch
   tst.l    D0
   beq      2$
   subq.l   #1,D0
   bne      range01
   move.l   D1,D0
1$ tst.b    D0
   bmi      range01
   move.l   D0,D2
   math     SPCmp
   bgt      range01
   move.l   D2,D0
2$ rts

range01
   ERR      out01

vint           dc.l  0
bpath          dc.l  0,0
oldx           dc.l  0,0
currdevpoint   dc.l  0,0,0,0

  DEF    currentgray
   move.l   graylevel,D0
  RETURN    Real


  DEF    setgray
   bsr      pop01
resetgray
   move.l   D0,graylevel
   lea      areasptrn,A0
   tst.l    D0
   beq      2$
   move.l   #FourPoint,D1
   math     SPMul
   math     SPFix
   moveq    #3,D1
   cmp.l    D1,D0
   bls      1$
   move.l   D1,D0
1$ add.l    D0,D0
   add.l    D0,D0
   add.l    D0,D0
   lea      areaptrn,A0
   add.l    D0,A0
2$ move.l   rastport,A1
   move.l   A0,8(A1)
   rts


  DEF    flood
   bsr      popxy
   bsr      newpoint
   moveq    #0,D2
   move.l   rastport,A1
   move.b   $19(A1),$1B(A1)
   graphics Flood
   rts

  DEF    fill
   lea      strokepathflag,A0
   move.b   (A0),D0
   move.b   #0,(A0)
   tst.b    D0
   bne      _stroke
   moveq    #-1,D0
   bra      ..strk

  DEF    strokepath
   move.b   #1,strokepathflag
   rts

  DEF    stroke
   moveq    #0,D0
   bsr      checklwidth    does line have width?
..strk
   movem.l  D5-D7/A2-A4,-(SP)
   move.l   D0,D7

   moveq    #-1,D0
   move.l   D0,buttremember
   move.l   D0,ibuttremember
   move.l   D0,buttbegin
   move.l   D0,ibuttbegin
   move.l   D0,a_linecap

   move.l   pstack,A0
   move.w   (A0)+,D0       pointcount at last newpath
   move.l   (A0),A2        nextpoint at last newpath

   move.w   pointcnt,D5
   sub.w    D0,D5
*   lea      pathbuffer,A2

1$ subq.w   #1,D5
   bmi      100$
   move.w   (A2)+,D6
   move.l   (A2)+,D2
   move.l   D2,D0
   math     SPFix
   move.l   D0,A3

   move.l   (A2)+,D3
   move.l   D3,D0
   math     SPFix
   move.l   #MaxY,D1
   sub.l    D0,D1
   move.l   A3,D0

   tst.l    D7
   bmi      4$
   bne      6$
   cmp.b    #c_moveto,D6
   bne      2$
   bsr      xmoveto
   bra      1$
2$
*   cmp.b    #c_lineto,D6
*   bne      1$
   bsr      xlineto
3$ bra      1$

4$ cmp.b    #c_moveto,D6
   bne      5$
   graphics AreaMove
   bra      1$
5$
*   cmp.b    #c_lineto,D6
*   bne      1$
   graphics AreaDraw
   bra      1$

6$ cmp.b    #c_moveto,D6
   bne      7$
   movem.l  D0-D3,arsource

* put caps on ends of last subpath
   bsr      dolinecaps

   moveq    #-1,D0
   move.l   D0,buttremember
   move.l   D0,ibuttremember
   move.l   D0,buttbegin
   move.l   D0,ibuttbegin
   move.l   D0,a_linecap
   bra      1$

* draw thick stroke by filling
7$
*   cmp.b    #c_lineto,D6
*   bne      1$
   lea      ardest,A4
   movem.l  D0-D3,(A4)
   lea      arsource,A3

*   sub.l    (A3),D0
*   bpl      71$
*   neg.l    D0
*71$
*   sub.l    4(A3),D1
*   bpl      72$
*   neg.l    D1
*72$
*   add.l    D1,D0
*   cmp.l    #4,D0
*   blt      1$

* rmath routine calculates sides of right triangle whose
* hypotenuse is perpendicular to this stroke and is
* 1/2 linewidth in length -- returns x-side in D2, y-side in D3
* also y in D0, x in D1 in device coordinates for x and y axes, resp.
   bsr      xywidth
   movem.l  D0/D1,deltayx
   movem.l  buttremember,D0/D1
   tst.l    D0
   bpl      8$
* 1st corner  at beginning of subpath
   movem.l  (A3),D0/D1

   lea      a_linecap,A0
   movem.l  D0-D3,(A0)
   movem.l  deltayx,D0/D1
   movem.l  D0/D1,16(A0)
   movem.l  (A0),D0/D1

   sub.l    D2,D0
   sub.l    D3,D1
   movem.l  D0/D1,buttbegin
8$ movem.l  D0/D1,-(SP)    save to close rectangle at end
   bsr      qamove

   move.l   buttremember,D0
   bmi      9$
* connect 2nd corner of last stroke to 1st corner of this one
   movem.l  (A3),D0/D1
   sub.l    D2,D0
   sub.l    D3,D1
   bsr      qadraw

9$
* 2nd corner
   movem.l  (A4),D0/D1

   lea      b_linecap,A0
   movem.l  D0-D3,(A0)
   movem.l  deltayx,D0/D1
   movem.l  D0/D1,16(A0)
   movem.l  (A0),D0/D1

   sub.l    D2,D0
   sub.l    D3,D1
   movem.l  D0/D1,buttremember
   bsr      qadraw

   cmp.b    #c_closepath,D6
   bne      10$
* signal don't do linecaps
   moveq    #-1,D0
   move.l   D0,a_linecap

* connect 2nd corner to 1st corner of stroke at
* beginning of subpath
   movem.l  buttbegin,D0/D1
   tst.l    D0
   bmi      10$
   bsr      qadraw
   movem.l  ibuttbegin,D0/D1
   tst.l    D0
   bmi      10$
   bsr      qadraw

10$
* 3rd corner
   movem.l  ibuttremember,D0/D1
   movem.l  D0/D1,-(SP)

   movem.l  (A4),D0/D1
   add.l    D2,D0
   add.l    D3,D1
   movem.l  D0/D1,ibuttremember
* may want move here instead of interior line
   bsr      qadraw

* 4th corner
   movem.l  (A3),D0/D1
   add.l    D2,D0
   add.l    D3,D1
   lea      ibuttbegin,A0
   tst.l    (A0)
   bpl      11$
   movem.l  D0/D1,(A0)
11$
   bsr      qadraw

* connect 4th corner to 3rd corner of last stroke
   movem.l  (SP)+,D0/D1
   tst.l    D0
   bmi      12$
   bsr      qadraw

12$
* close rectangle
   movem.l  (SP)+,D0/D1
   bsr      qadraw

* fill it
   bsr      qaend

   movem.l  (A4),D0-D3  this destination will be next source
   movem.l  D0-D3,(A3)
   bra      1$


100$
   bsr      dolinecaps
   move.l   D7,D0
   movem.l  (SP)+,D5-D7/A2-A4
   tst.l    D0
   bpl      _newpath
   graphics AreaEnd
   bra      _newpath


qamove
   tst.b    strokepathflag
   bne      1$
   move.l   D2,D4
   or.l     D3,D4
   beq      1$
   graphics AreaMove
   tst.l    D0
   bmi      pointprob
   rts
1$ movem.l  D2/D3,-(SP)
   bsr      xmoveto
   movem.l  (SP)+,D2/D3
   rts

qadraw
   move.l   D2,D4
   or.l     D3,D4
   beq      1$
   tst.b    strokepathflag
   bne      ..qnd
   graphics AreaDraw
   tst.l    D0
   bmi      pointprob
1$ rts
..qnd
   movem.l  D2/D3,-(SP)
   bsr      xxlineto
   movem.l  (SP)+,D2/D3
   rts

qaend
   move.l   D2,D4
   or.l     D3,D4
   beq      ..qnd
   tst.b    strokepathflag
   bne      1$
   graphics AreaEnd
1$ rts


dolinecaps
   movem.l  D5/D6,-(SP)
   lea      a_linecap,A3
   tst.l    (A3)
   bmi      100$
   move.w   linecap,D0
   beq      100$
   cmp.b    #2,D0
   beq      100$     no round ones yet

   movem.l  (A3),D0-D5
   move.l   D4,D6

   bsr      onecap
   moveq    #-1,D0
   move.l   D0,(A3)     signal did it

   lea      b_linecap,A3
   movem.l  (A3),D0-D5
   move.l   D4,D6

   add.l    D5,D0
   sub.l    D4,D1
   movem.l  D0/D1,(A3)
   bsr      onecap

100$
   movem.l  (SP)+,D5/D6
   rts


onecap

   movem.l  (A3),D0-D3
   sub.l    D2,D0
   sub.l    D5,D0

   sub.l    D3,D1
   add.l    D6,D1

   movem.l  D0/D1,-(SP)
   bsr      qamove

   movem.l  (A3),D0-D3
   sub.l    D2,D0
   sub.l    D3,D1
   bsr      qadraw

   movem.l  (A3),D0-D3
   add.l    D2,D0
   add.l    D3,D1
   bsr      qadraw

   movem.l  (A3),D0-D3
   add.l    D2,D0
   sub.l    D5,D0
   add.l    D3,D1
   add.l    D6,D1
   bsr      qadraw

   movem.l  (SP)+,D0/D1
   bsr      qadraw

   bra      qaend



  DEF    setlinecap
   bsr      popnum
   tst.l    D0
   bmi      type_mismatch
   cmp.l    #2,D0
   bgt      type_mismatch
   move.w   D0,linecap
   rts

  DEF    currentlinecap
   moveq    #0,D0
   move.w   linecap,D0
   RETURN   Integer


  DEF    setlinejoin
   bsr      popnum
   tst.l    D0
   bmi      type_mismatch
   cmp.l    #2,D0
   bgt      type_mismatch
   move.w   D0,linejoin
   rts

  DEF    currentlinejoin
   moveq    #0,D0
   move.w   linejoin,D0
   RETURN   Integer


arsource    dc.l  0,0,0,0
ardest      dc.l  0,0,0,0
deltayx     dc.l  0,0
buttremember   dc.l  0,0
ibuttremember  dc.l  0,0
buttbegin      dc.l  0,0
ibuttbegin     dc.l  0,0
a_linecap      dc.l  0,0,0,0,0,0
b_linecap      dc.l  0,0,0,0,0,0



  DEF    erasepage
   move.l   rastport,A1
   move.l   8(A1),-(SP)    save pattern
   moveq    #0,D0
   move.b   $19(A1),D0     save fgpen
   move.l   D0,-(SP)
   move.b   $1C(A1),D0     save draw mode
   move.l   D0,-(SP)
   lea      areasptrn,A0   solid pattern
   move.l   A0,8(A1)

   moveq    #0,D0
   graphics SetDrMd

   moveq    #0,D0
   graphics SetAPen

   moveq    #0,D0
   move.l   D0,D1
   move.l   #639,D2
   move.l   #MaxY,D3

   move.l   A1,-(SP)
   graphics RectFill
   move.l   (SP)+,A1
   move.l   (SP)+,D0       old mode
   move.l   (SP)+,D2       old fg pen
   move.l   (SP)+,8(A1)    old pattern

   graphics SetDrMd
   move.l   D2,D0
   graphics SetAPen
   rts

* above substituted for following, since system
* was corrupted by ClearScreen
*   lea      $24(A1),A2
*   move.l   (A2),-(SP)     save currentpoint
*   clr.l    (A2)           home
*   graphics ClearScreen
*   move.l   (SP)+,(A2)
*   rts

  DEF    pencolor
   bsr      popnum
   moveq    #PenMask,D1
   and.l    D1,D0
   graphics SetAPen
   rts

  DEF    penbcolor
   bsr      popnum
   moveq    #PenMask,D1
   and.l    D1,D0
   graphics SetBPen
   rts

  DEF    penmode
   bsr      popnum
   graphics SetDrMd
   rts

  DEF    penpattern
   bsr      popnum
   move.l   rastport,A1
   move.w   D0,$22(A1)
   rts

  DEF    box
   bsr      popxy
   bsr      newpoint
   movem.l  D0/D1,-(SP)
   bsr      popxy
   bsr      newpoint
   movem.l  (SP)+,D2/D3

   cmp.l    D2,D0
   bls      1$
   exg      D0,D2
1$ cmp.l    D3,D1
   bls      2$
   exg      D1,D3
2$
   graphics RectFill
   rts


  DEF    currentrgbcolor
   move.l   viewport,A0
   move.l   4(A0),A0       colormap
   move.l   rastport,A1
   moveq    #0,D0
   move.b   $19(A1),D0
   graphics GetRGB4
   move.l   D0,D3
   move.w   #Integer,D2
   moveq    #%1111,D1
   lsr      #8,D0
   and.l    D1,D0
   bsr      r.ipush
   move.l   D3,D0
   lsr      #4,D0
   and.l    D1,D0
   bsr      r.ipush
   move.l   D3,D0
   and.l    D1,D0
   bra      r.ipush

  DEF    setrgbcolor
   bsr      popnum
   move.l   D0,D3
   bsr      popnum
   move.l   D0,D4
   bsr      popnum
   move.l   D0,D1
   move.l   D4,D2

   move.l   viewport,A0
   move.l   rastport,A1

   moveq    #0,D0
   move.b   $19(A1),D0
   graphics SetRGB4
   rts

  DEF    findfont
   bsr      ipop
   move.l   D0,A1
   cmp.w    #Name,D2
   beq      1$
   cmp.w    #String,D2
   bne      type_mismatch
   move.b   (A1)+,D0
   bne      2$
1$ lea      fontdirectory,A2
   bsr      dictsearch
   tst.l    D2
   bmi      3$
  RETURN    FontID
2$ ERR      big_key
3$ ERR      no_font

  DEF    scalefont
   bsr      ipop
   move.l   D0,D1
   move.w   D2,D3
  ARG    FontID
   move.l   D0,-(SP)
   move.w   #FontID,D2
   bsr      r.ipush
   move.l   D1,D0
   move.w   D3,D2
   bsr      r.ipush

   move.l   (SP)+,A0
   tst.w    (A0)
   bmi      _scaleg

   move.l   A0,-(SP)
   bsr      popnum
   move.l   (SP)+,A0
   move.w   D0,(A0)
   rts


  DEF    setfont
  ARG    FontID
resetfont
   move.l   D0,A2
   move.l   D0,A1
   move.w   (A1)+,D0    scaled size
   bmi      setresfont
   move.l   A1,D2       save ptr font address
   move.l   (A1)+,A0    font address, if open, and A1->TAttr
   addq.l   #4,A1
   move.w   (A1),D1     size in TAttr
   cmp.w    D1,D0
   beq      1$          req. size same as known size?
   move.w   D0,(A1)
   bra      2$          have to ask for new size
1$ move.l   A0,D0       already open?
   bne      4$          if so, use it
* correct font and size not known
* first see if it's on list of resident fonts
2$ lea      6(A2),A0    TAttr for following call
   graphics OpenFont
   tst.l    D0
   beq      20$         if was not found, try on disk

   move.l   D0,A0       for SetFont call
   move.l   D0,2(A2)    may as well keep address, even if wrong size
   move.w   $14(A0),D0  size of font found
   cmp.w    (A2),D0     same as scaled value?
   beq      4$          if so, go use it

20$
* well, maybe it's on disk
   bsr      opendflib   make sure diskfont lib is open
   tst.l    D0
   beq      3$          no diskfont lib

   move.l   A6,-(SP)
   move.l   D0,A6       diskfontbase
   lea      6(A2),A0    TAttr
   jsr      -$1E(A6)    OpenDiskFont
   move.l   (SP)+,A6

   move.l   D0,A0
   tst.l    D0
   bne      4$          got it?
3$ print    no_font     alternatives exhausted
   bra      reinterp
4$ sf       resfontflag
   move.l   A0,2(A2)    save font address
   move.l   A2,currfont for currentfont operator
   graphics SetFont
   rts


setresfont
   st       resfontflag
   move.l   A2,currfont
   rts

  DEF    currentfont
   move.l   currfont,D0
  RETURN    FontID

   xdef     currfont
currfont    dc.l  _topaz

*******

opendflib
   move.l   diskfontbase,D0
   bne      1$
   move.l   A6,-(SP)
   move.l   4,A6
   lea      dflibname,A1
   moveq    #0,D0
   jsr      -$228(A6)
   move.l   D0,diskfontbase
   move.l   (SP)+,A6
1$ rts

* not used yet
closedflib
   move.l   diskfontbase,D0
   beq      1$
   move.l   A6,-(SP)
   move.l   4,A6
   lea      dflibname,A1
   moveq    #0,D0
   jsr      -$19E(A6)
   moveq    #0,D0
   move.l   D0,diskfontbase
   move.l   (SP)+,A6
1$ rts


   section  gdata,data


diskfontbase   dc.l  0
dflibname      dc.b  'diskfont.library',0
resfontflag    dc.b  0
               cnop  0,2

newfont  macro
_\1      dc.w  \2
         dc.l  0
         dc.l  1$
         dc.w  \2
         dc.b  0
         dc.b  %01100011
1$       dc.b  '\1.font',0
         cnop  0,2
      endm

      newfont  topaz,8
      newfont  diamond,12
      newfont  ruby,12
      newfont  opal,11
      newfont  sapphire,19
      newfont  garnet,16
      newfont  emerald,20

_simplex    dc.w  $FFFF
            dc.w  Real
            dc.l  OnePoint

fentry   macro
         dc.l  .\1
         dc.w  FontID
         dc.l  _\1
         endm

nentry   macro
.\1      dc.b  1$-*-1
         dc.b  '\1'
1$
         endm

fontdirectory
   fentry   topaz
   fentry   diamond
   fentry   ruby
   fentry   opal
   fentry   sapphire
   fentry   garnet
   fentry   emerald
   fentry   simplex

   dc.l     0

fontnames
   nentry   topaz
   nentry   diamond
   nentry   ruby
   nentry   opal
   nentry   sapphire
   nentry   garnet
   nentry   emerald
   nentry   simplex

   bstr     no_font,<can''t find font>
   bstr     big_key,<key too long>
   bstr     psov,<gsave overflow>
   bstr     psuv,<grestore underflow>
   bstr     pntsov,<too many points in path>
   bstr     out01,<arg outside 0...1 interval>

   cnop     0,2

linecap     dc.w  1     0=butt, 1=round, 2=projecting square
linejoin    dc.w  0

graylevel   dc.l  0

areasptrn
            dc.w  %1111111111111111
            dc.w  %1111111111111111
            dc.w  %1111111111111111
            dc.w  %1111111111111111

areaptrn
            dc.w  %0111011101110111
            dc.w  %1101110111011101
            dc.w  %0111011101110111
            dc.w  %1101110111011101

            dc.w  %0101010101010101
            dc.w  %1010101010101010
            dc.w  %0101010101010101
            dc.w  %1010101010101010

            dc.w  %0001000100010001
            dc.w  %0100010001000100
            dc.w  %0001000100010001
            dc.w  %0100010001000100

            dc.w  0,0,0,0

   xdef  strokepathflag
strokepathflag    dc.w  0

   section  groom,bss

pstackcnt   ds.w  1
pstack      ds.l  1
            ds.b  18*PstackSize
pstacktop   ds.w  1
            ds.l  1


pointcnt    ds.w  1
nextpoint   ds.l  1

tmpras      ds.l  2
areainfo    ds.l  4
            ds.w  4

areabuffer  ds.b  5*AreaSize

pathbuffer  ds.b  10*AreaSize

   end