section gprint

;       standard GPRINT header

        dc.w    'EJ'            ;These 2 bytes are not significant
                                ;so I use them for my initials !
ID1     dc.b    'GSD1'          ;The next 10 bytes ARE significant
        dc.w    GEnd-Start

Start   BRA.S   Entry1
        BRA.L   Entry2


Entry1  MOVEM.L D0/D1/D2/D3/D4/D5/D6/A0/A1/A2/A3/A4/A6,-(A7)

        BSR.S   OpenDev
        BNE.S   Error2
        MOVE.L  A0,A4
        LEA     Flag1(PC),A2
        TST.B   (A2)
        BEQ.S   DmpLoop
        BSR.L   Alloc
        BNE.S   Error2
        MOVE.L  A0,-(A7)
        SUBA.L  A0,A0
        JSR     Dump1(PC)       ;set up
        MOVE.L  (A7)+,A4

DmpLoop MOVE.L  A4,A0           ;Dump ...
        JSR     Dump1(PC)
        BEQ.S   NoError         ;... until no more data ...
        JSR     Write(PC)
        BNE.S   Close1          ;or an error (or ESC) happens
        BRA.S   DmpLoop

NoError CLR.L   D7

Close1  LEA     Flag1(PC),A2
        TST.B   (A2)
        BEQ.S   Close2
        BSR.L   Dealloc

Close2  MOVE.L  ChanID(PC),A0
        MOVEQ   #$2,D0
        TRAP    #$2
        MOVEM.L (A7)+,D0/D1/D2/D3/D4/D5/D6/A0/A1/A2/A3/A4/A6
        MOVE.L  D7,D0
        RTS

OpenDev MOVEM.L D0/D1/D2/D3/A0/A1,-(A7)
        lea     DevName+2,a0
        tst.w   (a0)
        bne.s   OpenIt

        MOVEQ   #$0,D0
        TRAP    #$1                     ;sysvars to A0
        MOVE.L  $B4(A0),A0              ;get spl_use

OpenIt  MOVEQ   #$1,D0
        moveq   #-1,d1
        MOVEQ   #$3,D3
        TRAP    #$2
        LEA     ChanID(PC),A1
        MOVE.L  A0,(A1)
        TST.L   D0
        MOVEM.L (A7)+,D0/D1/D2/D3/A0/A1
        RTS

Error1  MOVE.L  #$8301,D7
        BRA.S   Close1

Error2  MOVE.L  #$8301,D7
        BRA.S   Close2

Entry2  LEA     Flag1(PC),A2
        CLR.B   (A2)
        JMP     Dump1(PC)

Write   MOVEM.L D0/D1/D2/D3/A0/A1/A2,-(A7)
        MOVE.L  A0,A1
        MOVE.L  ChanID(PC),A0
        MOVE.W  D0,D2
        MOVEQ   #$7,D0
        MOVE.W  #$5DC,D3
        TRAP    #$3
        TST.L   D0
        MOVEM.L (A7)+,D0/D1/D2/D3/A0/A1/A2
        BNE.S   LC48
lc2a    MOVE.L  A0,D7
        movea.l $1392(a5),a0
        MOVEQ   #$0,D3
        MOVEQ   #$1,D0
        TRAP    #$3
        MOVE.L  D7,A0
        TST.L   D0
        BNE.S   LC44
        CMPI.B  #$1B,D1
        BNE.S   LC2A
        MOVEQ   #$1B,D7
        BRA.S   LC48

LC44    CLR.B   D0
        RTS

LC48    MOVEQ   #$1,D0
        RTS

Alloc   MOVEM.L D0/D1/D2/D3/A1/A2/A3,-(A7)
        MOVEQ   #$18,D0
        MOVEQ   #$FF,D2
        CLR.L   D1
        MOVE.W  BufSize(PC),D1
        TRAP    #$1
        TST.L   D0
        MOVEM.L (A7)+,D0/D1/D2/D3/A1/A2/A3
        RTS

Dealloc MOVE.L  A4,A0
        MOVEQ   #$19,D0
        TRAP    #$1
        RTS


Flag1   dc.b    1,0

ChanID  dc.l    0

ID2     dc.l    'GSD1'
        dc.w    GEnd-Start2
Start2

Dump1   MOVE.L  A0,D0
        BNE.S   Dump2
        LEA     ScrAddr(PC),A0
        CLR.L   (A0)
        MOVE.W  BufSize(PC),D0
        LEA     LD6C(PC),A0
        RTS

Dump2   MOVEM.L D3/D4/D5/A1/A3/A4/A6,-(A7)
        MOVE.L  A0,A4
        MOVE.L  ScrAddr(PC),A3          ;where are we to dump from
        MOVE.L  A3,D0                   ;well, have we started dumping at all ?
        BNE.S   LCCA                    ;yes, go dump

        LEA     ScrAddr(PC),A0          ;calculate initial screen address
        MOVE.W  -6(A5),D0

        MULU    #2*6,D0                 ;skip 6 pixel-lines

OffOK   ADD.L   -4(A5),D0               ;add screen base to offset
        addq.l  #4,d0                   ;skip first 16 pixels
        MOVE.L  D0,(A0)                 ;store for next time around

        lea     IsFirst,a0              ;signal that the next loop needs
        sf      (a0)                    ;to skip initial empty lines

        LEA     GInit(PC),A0            ;and return GInit to caller
        MOVEQ   #$3,D0
        BRA.S   DumpEnd

LCCA    lea     IsFirst,a1              ;is this the first loop after
        tas     (a1)                    ;initialising ?
        bne.s   NotFirst                ;no. Note how we also reset the flag.

A3_Loop move.l  (a3),d0                 ;scan downwards until we meet data
        or.l    4(a3),d0                ;in the first 32 pixels on the line
        bne.s   A3_Ok
        adda.w  -6(a5),a3
        adda.w  -6(a5),a3
        bra.s   A3_Loop
A3_Ok   lea     ScrAddr,a1              ;store new correct value of A3
        move.l  a3,(a1)
NotFirst

        MOVE.L  GStart(PC),(A0)+        ;prefix data with GStart
        BSR.L   DmpLine0                ;calculate data from pixels
        MOVE.L  A4,A1
        ADDQ.L  #4,A1                   ;start of data
LCD6    TST.L   (A1)+                   ;check data, is it all zero ?
        BNE.S   LCE0                    ;this will happen when dumping
        CMPA.L  A0,A1                   ;pie-charts, as the last few lines
        BLT.S   LCD6                    ;are empty.
        MOVE.L  A4,A0                   ;Yes, the data is all zero. So we
        clr.l   d0                      ;print nothing at all, not even CRLF !
        bra.s   DataOK

LCE0    MOVE.W  GNext(PC),(A0)+         ;postfix data with GNext (CRLF)
        SUBA.L  A4,A0
        MOVE.L  A0,D0                   ;calculate length
        MOVE.L  A4,A0

DataOK  LEA     ScrAddr(PC),A6          ;get ready for next time round
        move.w  -6(a5),d3
        MULU    #$8,D3
        ADD.L   D3,(A6)

        MULU    #$39,D3                 ;unless we are all done
        ADD.L   -4(A5),D3
        CMP.L   (A6),D3
        BGE.S   DumpEnd

        clr.l   d0
        LEA     GFeed(PC),A0
        MOVEQ   #$1,D1

DumpEnd MOVEM.L (A7)+,D3/D4/D5/A1/A3/A4/A6
        TST.L   D0
        RTS

GInit   dc.b    $1b,$33,$18,0              ;set lf distance
GStart  dc.b    $1b,$4c,$c0,$03            ;graphics header
GNext   dc.b    13,10                      ;cr lf
GFeed   dc.b    12,0                       ;ff

DmpLine0
        btst    #0,$704(a5)             ;what mode are we in ?
        bne     DmpLine8

DmpLine MOVEM.L D3/D4/D5/D6/D7,-(A7)
        MOVEQ   #60-1,D2                ;60 words * 8 pixels per word
WordLoop
        moveq   #7,d5                   ;8 pixels per word
PixLoop
        MOVE.W  -6(A5),D4
        MULU    #$6,D4                  ;offset to bottom line
        MOVEQ   #$3,D3                  ;bitmask of lower line
        CLR.B   D0
        CLR.B   D1

LinLoop
        CLR.B   D6                      ;assume black
        CLR.B   D7
        btst    d5,0(a3,d4.w)           ;green ?
        BEQ.S   NoGrn
        MOVE.B  #$AA,D6                 ;yes, use checkerboard pattern
        MOVE.B  #$55,D7
NoGrn

        BTST    D5,$1(A3,D4.W)          ;red ?
        BEQ.S   NoRed
        OR.B    D7,D6                   ;if previous green, make d6 = $ff
        ORI.B   #$AA,D7                 ;set a pixel
NoRed

        AND.B   D3,D6
        OR.B    D6,D0                   ;add this pixel to data
        AND.B   D3,D7
        OR.B    D7,D1                   ;add this pixel to data
        ASL.B   #2,D3                   ;next mask
        SUB.W   -6(A5),D4
        SUB.W   -6(A5),D4
        BPL.S   LinLoop
        MOVE.B  D0,(A0)+
        MOVE.B  D1,(A0)+
        DBF     D5,PixLoop
        ADDQ.W  #2,A3
        DBF     D2,WordLoop
        MOVEM.L (A7)+,D3/D4/D5/D6/D7
        RTS

DmpLine8
        MOVEM.L a1/D3/D4/D5/D6/D7,-(A7)
        MOVEQ   #60-1,D2                ;60 words * 8 pixels per word
WrdLoop8
        moveq   #3,d5                   ;4 pixels per word
PixLoop8
        MOVE.W  -6(A5),D4
        MULU    #$6,D4                  ;offset to bottom line
        MOVEQ   #$3,D3                  ;bitmask of lower line

        clr.l   (a0)                    ;initialise data

LinLoop8
        clr.w   d0                      ;assume black

        move.l  d5,d1
        asl.w   #1,d1
        addq.b  #1,d1

        btst    d1,0(a3,d4.w)           ;green ?
        beq.s   NoGrn8
        addq.b  #4,d0
NoGrn8
        btst    d1,1(a3,d4.w)           ;red ?
        beq.s   NoRed8
        addq.b  #2,d0
NoRed8
        subq.b  #1,d1
        btst    d1,1(a3,d4.w)           ;blue
        beq.s   NoBlue8
        addq.b  #1,d0
NoBlue8

        ;d0.w now holds color of pixel !

        lea     data0,a1
        asl.w   #2,d0
        adda.w  d0,a1                   ;a1 points to bit pattern for color

        move.b  (a1)+,d0                ;get bitpattern, select correct part
        and.b   d3,d0
        or.b    d0,(a0)                 ;add it to data
        move.b  (a1)+,d0
        and.b   d3,d0
        or.b    d0,1(a0)
        move.b  (a1)+,d0
        and.b   d3,d0
        or.b    d0,2(a0)
        move.b  (a1)+,d0
        and.b   d3,d0
        or.b    d0,3(a0)

        ASL.B   #2,D3                   ;next mask
        SUB.W   -6(A5),D4
        SUB.W   -6(A5),D4
        BPL.S   LinLoop8
        addq.l  #4,a0
        DBF     D5,PixLoop8
        ADDQ.W  #2,A3
        DBF     D2,WrdLoop8
        MOVEM.L (A7)+,a1/D3/D4/D5/D6/D7
        RTS

data0   dc.l    $00000000       ;bitpatterns for black (white on printout)
data1   dc.l    $00550000       ;blue
data2   dc.l    $aa005500
data3   dc.l    $55aa5500
data4   dc.l    $aa55aa55
data5   dc.l    $55ff55aa
data6   dc.l    $ff55aaff
data7   dc.l    $ffffffff       ;white (all black on printout)

DevName dc.w    36,3
        dc.b    'PAR'
        ds.b    36-3

IsFirst dc.w    0       ;zero if base has just been set

Ld6c    dc.w    1,5                     ; ????
ld70    dc.w    1,4                     ; ????

ScrAddr dc.l    0
BufSize dc.w    $3d4    ;length of buffer for data

GEnd    ;end of this file as far as Xchange is concerned

;       Configuration block, needs not be loded into Xchange

        dc.w    '<<QCFX>>01'
        dc.w    41
        dc.b    'Epson / IBM screendump for Xchange V3.90H'
        dc.w    4
        dc.b    '1.01'

        dc.b    0,0
        dc.w    DevName-*
        dc.w    0,0
        dc.w    DevDesc-*
        dc.w    DevAttr-*

        dc.w    -1

DevDesc dc.w    42
        dc.b    'Device to send dump to (empty for SPL_USE)'

DevAttr dc.w    0

        END