[ 53280,0:53281,0:646,(162):"":" USE LYNX TO DISSOLVE THIS FILE":10 3 *LYNX XV BY WILL CORLEY 14 GEOBEAPII.LN.CVT 8 S 117 S/0GEOBEAPII.CVT 78 S 10 S/1GEOBEAPII.CVT 44 S 98 S/2GBRLE.CVT 39 S 109 S/3GBRLEI.CVT 46 S 125 S/4GBD64I.CVT 32 S 169 S/5GBBEAPI.CVT 64 S 90 S/6GBZIP4.CVT 73 S 72 S/7GBCVT.CVT 22 S 118 S/8GBLNX.CVT 86 S 231 S/9GBARK.CVT 67 S 183 H/GEOBEAPII.CVT 9 S 70 S/GBMODTNS.CVT 13 S 82 GEOBEAPDOCS.CVT 113 S 94 geoBEAPII.lnkPRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&uP ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .output geoBEAP_2.1 P.header H/geoBEAPII.rel .vlir .psect $0400 ; beginning of main .ramsect $2000 ; must mark end of main S/0geoBEAPII.rel S/gbMODtns.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod 1 .psect VPRGbase ; setup S/1geoBEAPII.rel .mod 2 .psect VPRGbase ; geoRLE image S/2gbRLE.rel MODsecIO.rel .mod 3 .psect VPRGbase ; geoMultiRLE images S/3gbRLEi.rel MODsecIO.rel .mod 4 .psect VPRGbase ; D64/71/81 image S/4gbD64i.rel MODsecIO.rel .mod 5 .psect VPRGbase ; geoBEAP image S/5gbBEAPi.rel MODsecIO.rel .mod 6 .psect VPRGbase ; Zipcode+4 image S/6gbZIP4.rel MODsecIO.rel .mod 7 .psect VPRGbase ; .CVT convert S/7gbCVT.rel MODfcopy.rel MODconvert.rel .mod 8 .psect VPRGbase ; .LNX convert S/8gbLNX.rel MODfcopy.rel MODconvert.rel .mod 9 .psect VPRGbase ; .ARK convert S/9gbARK.rel MODfcopy.rel MODconvert.rel FhPGh`.dbg h ͅ  e¥HH ͅ thh+0 4H h e eS/0geoBEAPII.MPRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&8Pu]uDU X 0P ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;***************************** .if Pass1 .include GEOSequates DrawScrn=$10 AboutBox=$13 .endif .psect   Sequates .eqin .glbl .endif  .psect jmp Go2BEAP ; VPRGbase + 0 0 jmp AbtBox ; VPRGbase + 3 MODtns.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod0P0 @ProgStart : jsr i_InitVPrg ; init the VLIR vectors .word PermName cpx #0 ; check for errors bne ByeBye ; if any, then exit ldw ADW4080,#0 cwi rightMargin,#319 ; are we in 80 cols? ble 10$ ldw Flag4080,#$80 ; set 40/80 flag 10$:  @ReStart: ldb dispBufferOn,#(ST_WR_FORE|ST_WR_BACK) jsr UseSystemFont ldb A2L,#DrawScrn jsr vjmp ; now draw the main screen lda #0 jsr SelFmt ; initialiZe checkboxes to unpack ldb PackUnpack,#1 jsr UnpackDims ; by setting and inverting jsr InvertRectangle ldw OtherPressVec,#CMclick ; now set click handler jsr InitFiles mvb curDrive,BootDrv rts ; return to geos kernal ByeBye: jmp EnterDeskTop PermName: .byte "geoBEAP V2.1",0 0P0 @vjmp: mvb A2L,TempCurr @  jsr VJump jsr Imprint jsr i_OKBox .word ProperDisk ldb VPRGcurr,#$ff mvb TempCurr,A2L jmp vjmp ProperDisk: .byte $18,"Please re-insert geoBEAP disk.",27,0  @Imprint:  ldb R2L,#$00 mvb windowBot,R2H ldw R3,#$00 mvw rightMargin,R4 jmp ImprintRectangle UseSystemFont ldb A2L,#DrawScrn jsr vjmp ; now draw the main screen lda #0 jsr SelFmt ; initialiZe checkboxes to unpack ldb PackUnpack,#1 jsr UnpackDims ; by setting an0P0 @InitFiles: mvb curDevice,SrcDrv mvb curDevice,DstDrv jsr NewSrc jsr ShowSrc jsr NewDst jsr ShowDst rts GetSPtr: ldw A0,#SrcList ldx #$ff cpy #0 bne 10$ rts 10$: inx ; if first char is 0, we are DONE lda SrcList,x beq 12$ 11$: inx lda SrcList,x bne 11$ dey bne 10$ inx 12$: stx Temp ldb Temp+1,#0 adw Temp,A0 rts List,x beq 12$ 11$: inx lda SrcList,x bne 11$ dey bne 10$ inx 12$: stx Temp ldb Temp+1,#0 adw Temp,A0 rts ms: ldb R2L,#53 ldb 0P0 @NewSrc: ldw R0,#EndSrc-SrcList ldw R1,#SrcList ; initialize list areas jsr ClearRam  @ReadSrc: lda SrcDrv jsr SetDevice ; set proper disk jsr OpenDisk ldw A3,#SrcNam ldw A4,#21+19 jsr FixNam ldw A2,#SrcList ldw A3,#SrcPage-1 mvb SrcPage,A4L ldb A4H,#13 jsr File2List pha cpx #0 beq 11$ jsr FError ldb SrcList,#0 11$: pla rts SrcBoxDims: ldb R2L,#53 ; start source ldb R2H,#158 ldw R3,#21 ldw R4,#118 adw ADW4080,R3 adw ADW4080,R4 rts ;* send A3 with name pointing area, send A4 with X pos FixNam: lda #0 ; clear it first! jsr SetPattern mvw A4,R3 adw ADW4080,R3 mvw R3,R4 avw #88,R4 ldb R2L,53-15 ldb R2H,53-4 jsr Rectangle ldx #A2L jsr GetPtrCurDkNm jsr CopyFnam ; copy disk name mvw A3,R0 ldb R1H,#53-6 mvw A4,R11 adw ADW4080,R11 jsr PutString ; display disk name rts r down we are in dest list EndDst: .block 1s it the boot drive? ldw A2,#DKtxt1 jsr CNCLBox ; yes, so inform ldx #$ff ; otherwise, return error rts 11$: ldw A0P0 @ShowSrc:  jsr SrcBoxDims lda #0 jsr SetPattern jsr Rectangle jsr SrcBoxDims @  ldw A2,#SrcList ldb A3L,#0 jsr PrntList ; start destination mvb SrcPage,Temp ; now check clicked mvb SrcPage,Temp+1 avb #13,Temp+1 10$: ldy Temp ; by looping lda SrcPicks,y beq 11$ sty A2L inc A2L ; since FileList is 1 based sbb SrcPage,A2L jsr PikList 11$: inc Temp beq 12$ cpb Temp,Temp+1 ble 10$ 12$: rts ble 10$ rts ts ts DW4080,R3 adw ADW4080,R4 rts ;* send0P0 @NewDst: ldw R0,#EndDst-DstList ldw R1,#DstList ; initialize list areas jsr ClearRam @   @ReadDst: lda DstDrv jsr SetDevice jsr OpenDisk  ldw A3,#DstNam  ldw A4, #205+25 0P0 jsr FixNam ldw A2,#DstList ldw A3,#DstPage-1 mvb DstPage,A4L ldb A4H,#13 jsr File2List pha cpx #0 beq 11$ jsr FError ldb DstList,#0 11$: pla rts #205+25 adw ADW4080,R11 jsr PutString ; display disk name ldw A2,#DstList ldw A3,#0P0 @ShowDst:  jsr DstBoxDims lda #0 jsr SetPattern jsr Rectangle jsr DstBoxDims @  ldw A2,#DstList ldb A3L,#0 jsr PrntList rts DstBoxDims: ldb R2L,#53 ldb R2H,#158 ldw R3,#205 ldw R4,#303 adw ADW4080,R3 adw ADW4080,R4 rts cpx #0 beq 11$ jsr FError ldb DstList,#0 11$: pla rts  @ShowDst:  jsr DstBoxDims lda #0 jsr SetPattern jsr Rectangle jsr DstBoxDims @  ldw A2,#DstList ldb A3L,#0 jsr PrntList rts DstBoxDims: ldb R2L,#53 ldb 0P0 @DoDriveS:  lda SrcDrv jsr SetDevice jsr FBOXswd2 mvb curDrive,SrcDrv jsr NewSrc jmp ShowSrc  @DoDriveD:  lda DstDrv jsr SetDevice jsr FBOXswd2 mvb curDrive,DstDrv jsr NewDst jmp ShowDst  FBOXswd2:  ldy curDrive iny cpy #12 blt 11$ ldy #8 11$: tya jsr SetDevice  jsr OpenDisk cpx #0 bne FBOXswd2 rts con under source lda DstDrv ; set up source jsr DoDiskA beq 10$ rts 10$: jsr NewDst jsr ShowDst cpb SrcDrv,DstDrv beq 11$ rts 11$:0P0 ;******************** ;*  @DoDiskS  ;*  @DoDiskD  ;*  @DoDiskA  ;********************  @DoDiskS : ; ** handle disk icon under source lda SrcDrv ; set up source jsr DoDiskA beq 10$ rts 10$: jsr NewSrc jsr ShowSrc cpb SrcDrv,DstDrv beq 11$ rts 11$: jsr NewDst jmp ShowDst  @DoDiskD : ; ** handle disk icon under source lda DstDrv ; set up source jsr DoDiskA beq 10$ rts 10$: jsr NewDst jsr ShowDst cpb SrcDrv,DstDrv beq 11$ rts 11$: jsr NewSrc jmp ShowSrc  @DoDiskA: pha jsr SetDevice pla pha @  jsr DriveST cmp #4 ; is it native? blt 10$ cbi $c00f,#$40 ; is it wheels? blt 10$ cbi $904f,#$50 ; is the driver ok? blt 10$ pla lda #(5|64) jsr $9d80 ; get new kernal jsr $5003 ; change partition jsr $9d83 ; restore kernal bra 12$ 10$: pla ; pull the drive we came with cmp BootDrv bne 11$ ; is it the boot drive? ldw A2,#DKtxt1 jsr CNCLBox ; yes, so inform ldx #$ff ; otherwise, return error rts 11$: jsr DoDskN 12$: ldx #0 rts ompt for disk 12$: ldx #0 rts DKtxt0: .byte $18,"Please insert new disk.",27,0 DKtxt1: .byte $18,"Cannot remove geoBEAP disk.",27,0 ͅ  e¥HH ͅ thh+0 4H h e e0P0 @DoDskN: cmp DstDrv bne 10$ @  jsr DriveST cmp #4 blt 11$ @  10$: ldw A2,#DKtxt0 jmp OKBox ; prompt for disk 11$: lda #[(FmtDBX) sta $02 ; set lsb for dialog data lda #](FmtDBX) sta $03 ; set msb for dialog data jsr $c256 ; call DoDlgBox and leave! cbi sysDBData,#$14 bne 15$ lda DstDrv clc adc #$39 sta FTtxt00+23 ldb DskFmtFlg,#0 lda DstDrv jsr DriveST cmp #2 bne 13$ lda #[(Dlg7Fmt) sta $02 ; set lsb for dialog data lda #](Dlg7Fmt) sta $03 ; set msb for dialog data bra 14$ 13$: lda #[(DlgFmt) sta $02 ; set lsb for dialog data lda #](DlgFmt) sta $03 ; set msb for dialog data 14$: jsr $c256 ; call DoDlgBox and leave! cbi sysDBData,#$03 bne 15$ jmp DoFmtD 15$: rts FmtBut: .word FMTBMP ; pointer to graphics data .word $ffff FmtBut2: .byte $06,$10 ; pic width and height .word FmtCDG Fmt7But: .word FMT7BMP ; pointer to graphics data .word $ffff Fmt7But2: .byte $01,$08 ; pic width and height .word Fmt7CDG Fmt7CDG: dec DskFmtFlg beq 10$ ldb DskFmtFlg,#1 10$: jmp InvertRectangle FmtCDG: lda #$14 ; sysDBData code sta $851d jmp $c2bf ; RstrFrmDialogue FMTBMP: @FMT7BMP: A "Are you sure?",27,0 DKtxt0: .byte $18,"Please insert new disk.",27,0 DKtxt1: .byte $18,"Cannot rem0P0 @DoFmtD: lda DstDrv jsr SetDevice jsr PurgeTurbo jsr InitForIO lda DstDrv jsr DriveST cmp #2 bne 10$ lda DskFmtFlg bne 10$ lda #1 jsr DONED71 10$: lda #1 ; Logical file number ldx DstDrv ldy #15 ; command channel jsr $ffba ; setlfs lda #$0a ; strlen NEWDSKD ldx #[(NEWDSKD) ; ldy #](NEWDSKD) jsr $ffbd ; setnam jsr $ffc0 ; open lda #1 jsr $ffc3 ; close lda 90 pha lda DstDrv jsr DriveST cmp #$02 bne 11$ lda #2 ; yes, will already be 2, but 2=1571 jsr DONED71 11$: jsr DoneWithIO jsr EnterTurbo pla tax rts NEWDSKD: .byte "N0:DISK,ID",0 NEW1571D: .byte "U0>M0",0 DONED71: clc adc #$2f ; 1=1541, 2=1571 sta NEW1571D+4 lda #1 ; Logical file number ldx DstDrv ldy #15 ; command channel jsr $ffba ; setlfs lda #$05 ; strlen NEWDSKD ldx #[(NEW1571D) ; ldy #](NEW1571D) jsr $ffbd ; setnam jsr $ffc0 ; open lda #1 jmp $ffc3 ; close a #1 jmp $ffc3 ; close jsr CNCLBox ; yes, so inform ldx #$ff ; otherwise, return error rts 11$: jsr D0P0 @DoNxtD: lda #[(DNDlgT) sta $02 ; set lsb for dialog data lda #](DNDlgT) sta $03 ; set msb for dialog data jsr $c256 ; call DoDlgBox and leave! cbi sysDBData,#$14 bne 13$ lda DstDrv clc adc #$39 sta FTtxt00+23 ldb DskFmtFlg,#0 lda DstDrv jsr DriveST cmp #$02 bne 11$ lda #[(Dlg7Fmt) sta $02 ; set lsb for dialog data lda #](Dlg7Fmt) sta $03 ; set msb for dialog data bra 12$ 11$: lda #[(DlgFmt) sta $02 ; set lsb for dialog data lda #](DlgFmt) sta $03 ; set msb for dialog data 12$: jsr $c256 ; call DoDlgBox and leave! cbi sysDBData,#$03 bne 13$ jsr DoFmtD jmp DoNxtD ldb sysDBData,#$03 13$: lda SrcDrv jsr SetDevice ldx #0 rts Logical file number ldx DstDrv ldy #15 ; command channel jsr0P0 @; ********** ; Dialog boxes ; for Formatting ; **********  DNDlgT: .byte $81 ; size flag, and shadow pattern .byte $0c,$0a,$17 ; static text .byte A2 .byte $03,$01,$44 ; YES button .byte $04,$09,$44 ; NO button DNDlgT2: .byte $12,$11,$44 ; user clickbox .word FmtBut .byte $00 ; end of table DlgFmt: .byte $81 ; size flag, and shadow pattern .byte $0b,$0f,$12 ; static text .word FTtxt00 .byte $0b,$0f,$35 ; static text .word FTtxt02 .byte $0b,$0f,$41 ; static text .word FTtxt03 .byte $03,$10,$49 ; YES button .byte $04,$02,$49 ; NO button .byte $00 ; end of table Dlg7Fmt: .byte $81 ; size flag, and shadow pattern .byte $0b,$0f,$12 ; static text .word FTtxt00 Dlg7Fmt2: .byte $12,$02,$1c ; user clickbox .word Fmt7But .byte $0b,$1d,$22 ; static text .word FTtxt01 .byte $0b,$0f,$35 ; static text .word FTtxt02 .byte $0b,$0f,$41 ; static text .word FTtxt03 .byte $03,$10,$49 ; YES button .byte $04,$02,$49 ; NO button .byte $00 ; end of table FTtxt00: .byte $18,"Format disk in drive: A",27,0 FTtxt01: .byte $18,"Format 1571 double-sided",27,0 FTtxt02: .byte $18,"All data will be erased!",27,0 FTtxt03: .byte $18,"Are you sure?",27,0 DKtxt0: .byte $18,"Please insert new disk.",27,0 DKtxt1: .byte $18,"Cannot remove geoBEAP disk.",27,0 FmtDBX: .byte $81 ; size flag, and shadow pattern .byte $0b,$13,$1a ; static text .word DKtxt0 .byte $01,$10,$4a ; OK button .byte $12,$02,$4a ; user clickbox .word FmtBut .byte $00 ; end of table ,$81 .byte [(BEA0P0 ; ** send drive number in .a  @DriveST : ; ** return drive type in .a, total drives in .x ldx numDrives tay lda driveType-8,y and #%00000111 rts rts fba ; setlfs lda #$0a ; strlen NEWDSKD ldx #[(NEWDSKD) ; l0P0 @SelFmt: sta FormatCode tax ldw A1,#FmtTable cpx #0 beq 50$ 10$: inw A1 20$: inw A1 ldy #0 lda (A1),y bne 20$ inw A1 dex bne 10$ 50$: ldy #0 lda (A1),y sta ChainCode inw A1 lda (A1),y sta MethCode inw A1 mvw A1,R0 ldb R1H,#120 ldw R11,#130 adw ADW4080,R11 jsr PutString jmp UnSetSrc  @NewFormat:  ldx FormatCode inx cpx NUMFRMTS blt 10$ ldx #0 10$: txa jmp SelFmt NUMFRMTS: .byte 8 0PFmtTable: .byte $40,%00001111, 27,".D64/71/81 ",0 .byte $50,%00001111, 27,".BEP image ",0 .byte $70,%11111111, 27,".CVT GEOS ",0 .byte $60,%00001111, 27,"?!zipcode+4 ",0 .byte $80,%11110110, 27,".LNX LYNX ",0 .byte $90,%11110110, 27,".ARK Arkive ",0 .byte $20,%00001111, 27,".RLE (emutil)",0 .byte $30,%00001111, 27,".RLE ?-multi ",0   12$ 10$: pla ; pull the drive we came with cmp BootDrv bne 11$ ; is it the boot drive? ldw A2,#DKtxt1 jsr CNCLBox ; yes, so inform ldx #$ff ; otherwise, return error rts 11$: ldw A0P0 @CMclick: lda mouseData beq 10$ rts 10$: jsr ClickPack  @  jsr SrcBoxDims jsr ClkList cpx #0 bne 11$ rts 11$: dex stx A2L txa ; is it real? tay jsr GetSPtr ldy #0 ; see if null lda (A0),y bne 12$ ; if not, continue rts 12$: mvb A2L,Temp+10 jsr GetMeth cmp #$0f beq 15$ cmp #0 bne 13$ rts 13$: cpb SrcDrv,DstDrv bne 15$ jsr UnSetSrc 15$: mvb Temp+10,A2L mvb SrcPage,Temp adb A2L,Temp  @  jsr SrcBoxDims inc A2L jsr PikList ldy Temp lda SrcPicks,y beq 20$ lda #0 sta SrcPicks,y rts 20$: lda #1 sta SrcPicks,y rts BEP image ",0 .byte $70,%11111111, 27,".CVT GEOS ",0 .byte $60,%00001111, 27,"?!zipcode+4 ",0 .byte $80,%11110110, 27,".LNX LYNX ",0 .byte $90,%11110110, 27,".ARK0P0 @ClickPack : lda PackUnpack beq 20$ jsr PackDims jsr IsMseInRegion cmp #$ff bne 20$ jsr InvertRectangle jsr UnpackDims jsr InvertRectangle ldb PackUnpack,#0  jsr UnSetSrc  rts 0P020$: lda PackUnpack bne 30$ jsr UnpackDims jsr IsMseInRegion cmp #$ff bne 30$ jsr InvertRectangle jsr PackDims jsr InvertRectangle inc PackUnpack  jsr UnSetSrc  30$: rts 0P0 PackDims: ldb R2L,#61 ldb R2H,#69 jmp PakUnkDim UnpackDims: ldb R2L,#81 ldb R2H,#89 jmp PakUnkDim PakUnkDim: ldw R3,#131 ; in a pack box? ldw R4,#139 adw ADW4080,R3 adw ADW4080,R4 rts  0,R4 rts  0,R4 rts  $90,%11110110, 27,".ARK Arkive ",0 .byte $20,%00001111, 27,".RLE (@`0 @ClikDAro: lda mouseYPos sta Temp cmp #106 bge 20$ cbi DstPage,#13 bge 10$ rts 10$: cbi Temp,#76 bgt 22$ ; here is the up page ldb DstPage,#0 jsr ReadDst jmp ShowDst ; here the top page 20$: cbi DstPage,#255-13 ; 255 is max blt 21$ rts 21$: cbi Temp,#133 bge 30$ ; below is the simple down arrow avb #13,DstPage jsr ReadDst cmp #0 bgt 23$ 22$: svb #13,DstPage jsr ReadDst 23$: jmp ShowDst 30$: avb #13,DstPage ; here is the bottom arrow jsr ReadDst cmp #0 bgt 20$ bra 22$ 22$ 22$ ck 256 ; windowed list of dest files DstPage: .block 1 ; how far down we are in dest list EndSrcDst: .block 1rmName: .byte "geoBEAP V2.0",0  E۩`Lw  3F 3F 3FH @`0 @ClikSAro: lda mouseYPos sta Temp cmp #106 bge 20$ cbi SrcPage,#13 bge 10$ rts 10$: cbi Temp,#76 bgt 22$ ; here is the up page ldb SrcPage,#0 jsr ReadSrc jmp ShowSrc ; here the top page 20$: cbi SrcPage,#255-13 ; 255 is max blt 21$ rts 21$: cbi Temp,#133 bge 30$ ; below is the simple down arrow avb #13,SrcPage jsr ReadSrc cmp #0 bgt 23$ 22$: svb #13,SrcPage jsr ReadSrc 23$: jmp ShowSrc 30$: avb #13,SrcPage ; here is the bottom arrow jsr ReadSrc cmp #0 bgt 20$ bra 22$ bottom arrow ;jsr ReadSrc cmp #0 bgt 20$ bra 22$ cmp #0 bgt 20$ bra 22$ 22$ 22$ cmp #0 bgt 20$ bra 22$ 22$ 22$ 22$ cmp #0 bgt 20$ bra 22$ 22$ 22$ cmp #0 bgt 20$ bra 22$ 22$ cmp #0 bgt 20$ bra 22$ 22$ 22$ cmp@`0 @Exit: jsr i_YNBox .word YNTXT cbi sysDBData,#$03 beq 10$ rts 10$: ldb A2L,#AboutBox jsr vjmp jmp EnterDeskTop YNTXT: .byte $18,"Exit to deskTop?",27,0  @Launch: mvb ChainCode,A2L jmp vjmp ChainCode,A2L j@`0 @GetFirstFile: ldb SrcPage,#0 jsr ReadSrc ; read first page GFNewPg: ldb ListPtr,#0 mvb SrcPage,PickPtr GFNxtFil: ldy PickPtr lda SrcPicks,y ; did they pick THIS one? beq GetNxtFile ; NO, then skip jmp GFGood ; YES, so go do it  @GetNxtFile : inc ListPtr inc PickPtr beq 12$ ldy ListPtr cpy #13 ; no , so are we done with page? bge 10$ ; no, so keep going jmp GFNxtFil 10$: avb #13,SrcPage jsr ReadSrc ; read next page cmp #0 beq 11$ ; if more filenames, continue jmp GFNewPg 11$: svb #13,SrcPage jsr ReadSrc 12$: ldx #$ff ; otherwise, return error rts GFGood: ldy ListPtr jsr GetSPtr ldy #0 ; see if null lda (A0),y bne 15$ ; if not, continue jmp GetNxtFile 15$: ldx #$00 rts dx #$00 rts ts ts @`0 @GetMeth:  lda PackUnpack beq 11$ lda MethCode and #$0f rts 11$: lda MethCode lsr a lsr a lsr a lsr a rts  @UnSetSrc: jsr SrcBoxDims @  ldw A2,#SrcList mvb SrcPage,Temp ; now check clicked mvb SrcPage,Temp+1 avb #13,Temp+1 10$: ldy Temp ; by looping lda SrcPicks,y beq 11$ sty A2L inc A2L ; since FileList is 1 based sbb SrcPage,A2L jsr PikList 11$: inc Temp beq 12$ cpb Temp,Temp+1 ble 10$ 12$: ldy #0 lda #0 13$: sta SrcPicks,y iny bne 13$ rts s,y iny bne 13$ rts name of disk SrcDrv: .block 1 ; source drive SrcList: .block 256 ; list of source files SrcPage: .block 1 ; how far down we are in dest list SrcPicks: .block 256 ; list of picked source files EndSrc: .block 1 DstNam: .@`0 .ramsect  FormatCode: .block 1 ; code for format 0,1,2,... DskFmtFlg: .block 1 ; flag for switching to 41 mode ChainCode: .block 1 ; code for which vlir reference MethCode: .block 1 ; method info flags PackUnpack: .block 1 ; pack, unpack THEICONS: .block 80 ; click table ADW4080: .block 1 ; always $00 Flag4080: .block 1 ; $00=40 $80=80 Temp: .block 20 ; for whatever you want TempCurr: .block 1 ; for vjmp errors BootDrv: .block 1 ; boot drive ListPtr: .block 1 ; index into SrcList PickPtr: .block 1 ; index into SrcPics FileName: .block 30 ; the file being created (pack) SrcNam: .block 20 ; name of disk SrcDrv: .block 1 ; source drive SrcList: .block 256 ; list of source files SrcPage: .block 1 ; how far down we are in dest list SrcPicks: .block 256 ; list of picked source files EndSrc: .block 1 DstNam: .block 20 ; name of disk DstDrv: .block 1 ; destination drive DstList: .block 256 ; windowed list of dest files DstPage: .block 1 ; how far down we are in dest list EndDst: .block 1word DlgFmt7 .byte $00 ; end of table FTtxt00: .byte $18,"Format disk in drive: A",27,0 FTtxt02: .byte $18,"All data will be erased!",27,0 FTtxt03: .byte $18,"Are you sure?",27,0 DlgFmt7: lda DstDrv jsr DriveST cmp #$02 beq 11$ 10$: ccy<ûfc̓3>c̓3fc̓3fc̓3fcy3>; pS/1geoBEAPII(PRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&! ! +$ZZZ<b0P ; ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .if Pass1 0P .noeqin .noglbl  .include GEOSequates .eqin .glbl .endif  .psect jmp MakeScrn ; VPRGbase + 0 jmp AbtBox ; VPRGbase + 3 s.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod0P0 MakeScrn: lda Flag4080 beq 10$ ldw R0,#fBEAPSCRN jsr InitRam jsr FixWords jsr FixCons 10$: jsr MoveCons ldw R0,#BEAPSCRN jsr GraphicsString ; draw boxes, etc.. jsr DoWords ; write headings ldw R0,#THEICONS jsr DoIcons ; set up active icons rts ; set up active icons rts ; set up active icons rts PRGbase + 0 jmp AbtBox ; VPRGbase + 3 jmp AbtBox ; VPRGbase + 3 + 3 c text .word FTtxt00 .byte $0b,$0f,$35 ; static text .word FTtxt02 .byte $0b,$0f,$41 ; static 0P0 ;******************** ;*  @DoWords ;* MakeScreen ;********************  @DoWords : ; ** display the screen text jsr i_PutString DW1: .byte 15,0,47,$18,"Disk:",27,0 jsr i_PutString DW2: .byte 205,0,47,$18,"Disk:",27,0 jsr i_PutString DW3: .byte 143,0,67,27,"Pack",0 jsr i_PutString DW4: .byte 143,0,87,27,"Unpack",0 jsr i_PutString DW5: .byte 130,0,55,$18,"Mode",27,0 jsr i_PutString DW6: .byte 130,0,105,$18,"Format",27,0 jsr i_PutString DW7: .byte 45,0,32,$18,"Source",27,0 jsr i_PutString DW8: .byte 228,0,32,$18,"Destination",27,0 rts FixWords: mvb Flag4080,DW1+1 mvb Flag4080,DW2+1 mvb Flag4080,DW3+1 mvb Flag4080,DW4+1 mvb Flag4080,DW5+1 mvb Flag4080,DW6+1 mvb Flag4080,DW7+1 mvb Flag4080,DW8+1 rts ,64,65 .byte FRAME_RECTO,140,0,90 ; 66,67,68,69 .byte MOVEPENTO,121,0,53 ; source shadow,70,71,72,73 .byte RECTANGLETO,123,0,163 ; 74,75,76,77 .byte MOVEPENTO,11,0,162 ; 78,79,80,81 .byte RECTANGLETO,123,0,163 ; 82,83,84,85 .byte MOVEPENTO,57,1,0P0 BEAPSCRN: .byte NEWPATTERN,1 ; 0,1 .byte MOVEPENTO,0,0,0 ; 2,3,4,5 .byte RECTANGLETO,63,1,199 ; 6,7,8,9 .byte NEWPATTERN,0 ; lined header, 10,11 .byte MOVEPENTO,0,0,0 ; 12,13,14,15 .byte RECTANGLETO,63,1,199 ; 16,17,18,19 .byte NEWPATTERN,1 ; 20,21 .byte MOVEPENTO,0,0,0 ; 22,23,24,25 .byte FRAME_RECTO,63,1,14 ; 26,27,28,29 .byte MOVEPENTO,0,0,2 ; 30,31,32,33 .byte FRAME_RECTO,63,1,12 ; more lined header, 34,35,36,37 .byte MOVEPENTO,0,0,4 ; 38,39,40,41 .byte FRAME_RECTO,63,1,10 ; 42,43,44,45 .byte MOVEPENTO,0,0,6 ; 46,47,48,49 .byte FRAME_RECTO,63,1,8 ; 50,51,52,53 .byte MOVEPENTO,130,0,60 ; radial buttons for,54,55,56,57 .byte FRAME_RECTO,140,0,70 ; "conversion",58,59,60,61 .byte MOVEPENTO,130,0,80 ; 62,63,64,65 .byte FRAME_RECTO,140,0,90 ; 66,67,68,69 .byte MOVEPENTO,121,0,53 ; source shadow,70,71,72,73 .byte RECTANGLETO,123,0,163 ; 74,75,76,77 .byte MOVEPENTO,11,0,162 ; 78,79,80,81 .byte RECTANGLETO,123,0,163 ; 82,83,84,85 .byte MOVEPENTO,57,1,53 ; dest shadow,86,87,88,89 .byte RECTANGLETO,59,1,163 ; 90,91,92,93 .byte MOVEPENTO,203,0,162 ; 94,95,96,97 .byte RECTANGLETO,59,1,163 ; 98,99,100,101 .byte MOVEPENTO,8,0,50 ; source & dest boxes,102,103,104,105 .byte FRAME_RECTO,120,0,161 ; 106,107,108,109 .byte MOVEPENTO,200,0,50 ; 110,111,112,113 .byte FRAME_RECTO,56,1,161 ; 114,115,116,117 .byte ESC_PUTSTRING,110,0,10 ; title,118,119,120,121 .byte $18,$1a,"geoBEAP v2.1",27,0 fBEAPSCRN: .byte [(BEAPSCRN+8),](BEAPSCRN+8),1,$81 .byte [(BEAPSCRN+18),](BEAPSCRN+18),1,$81 .byte [(BEAPSCRN+28),](BEAPSCRN+28),1,$81 .byte [(BEAPSCRN+36),](BEAPSCRN+36),1,$81 .byte [(BEAPSCRN+44),](BEAPSCRN+44),1,$81 .byte [(BEAPSCRN+52),](BEAPSCRN+52),1,$81 .byte [(BEAPSCRN+56),](BEAPSCRN+56),1,$80 .byte [(BEAPSCRN+60),](BEAPSCRN+60),1,$80 .byte [(BEAPSCRN+64),](BEAPSCRN+64),1,$80 .byte [(BEAPSCRN+68),](BEAPSCRN+68),1,$80 .byte [(BEAPSCRN+72),](BEAPSCRN+72),1,$80 .byte [(BEAPSCRN+76),](BEAPSCRN+76),1,$80 .byte [(BEAPSCRN+80),](BEAPSCRN+80),1,$80 .byte [(BEAPSCRN+84),](BEAPSCRN+84),1,$80 .byte [(BEAPSCRN+88),](BEAPSCRN+88),1,$81 .byte [(BEAPSCRN+92),](BEAPSCRN+92),1,$81 .byte [(BEAPSCRN+96),](BEAPSCRN+96),1,$80 .byte [(BEAPSCRN+100),](BEAPSCRN+100),1,$81 .byte [(BEAPSCRN+104),](BEAPSCRN+104),1,$80 .byte [(BEAPSCRN+108),](BEAPSCRN+108),1,$80 .byte [(BEAPSCRN+112),](BEAPSCRN+112),1,$80 .byte [(BEAPSCRN+116),](BEAPSCRN+116),1,$81 .byte [(BEAPSCRN+119),](BEAPSCRN+119),2,130,$80 .byte 0,0,0,0 ,0,0 0P0 ;******************* ;* ClickBoxes ;******************* ClickBoxes: ; ** initialize the screen click boxes .byte 9 ; # entries .word 0 ; mouse x pos .byte 0 ; mouse y pos .word LAUcon CB1: .byte 17 ; click box x pos .byte 175 ; click box y pos .byte LAUw,LAUh ; width & height .word Launch .word EXIcon ; EXIT icon CB2: .byte 37 .byte 0 .byte EXIw,EXIh .word Exit .word DRVcon ; left DRIVE icon CB3: .byte 2 .byte 165 .byte DRVw,DRVh .word DoDriveS .word DRVcon ; right DRIVE icon CB4: .byte 26 .byte 165 .byte DRVw,DRVh .word DoDriveD .word DSKcon ; left DISK icon CB5: .byte 9 .byte 165 .byte DSKw,DSKh .word DoDiskS .word DSKcon ; right DISK icon CB6: .byte 33 .byte 165 .byte DSKw,DSKh .word DoDiskD .word AROcon ; source arrows CB7: .byte 1 .byte 50 .byte AROw,AROh .word ClikSAro .word AROcon ; dest arrows CB8: .byte 38 .byte 50 .byte AROw,AROh .word ClikDAro .word FMTcon ; format combobox CB9: .byte 16 .byte 110 .byte FMTw,FMTh .word NewFormat EndCon: .byte 0 yte 0 e 0 ewFormat EndCon: .byte 0 0 0 ewFormat EndCon: .byte 0 0 0 ewFormat EndCon: .byte 0 0 0 ,101 .byte MOVEPENTO,8,0,50 ; source & dest boxes,102,103,104,105 .byte FRAME_RECTO,120,0,161 ; 106,10P0 FixCons: ldw R0,#CB1 jsr FixOne ldw R0,#CB2 jsr FixOne ldw R0,#CB3 jsr FixOne ldw R0,#CB4 jsr FixOne ldw R0,#CB5 jsr FixOne ldw R0,#CB6 jsr FixOne ldw R0,#CB7 jsr FixOne ldw R0,#CB8 jsr FixOne ldw R0,#CB9 jsr FixOne ;ldw R0,#Dlg7Fmt2+1 ;jsr FixHalf ;ldw R0,#DNDlgT2+1 ;jsr FixHalf ldw R0,#Fmt7But2 jsr FixHalf ldw R0,#FmtBut2 jsr FixHalf rts MoveCons: ldw R0,#ClickBoxes ldw R1,#THEICONS ldy #$00 10$: lda (R0),y sta (R1),y cwi R0,#EndCon inw R0 inw R1 blt 10$ rts FixOne: ldy #0 lda (R0),y ora Flag4080 sta (R0),y ldy #2 lda (R0),y ora Flag4080 sta (R0),y rts FixHalf: ldy #0 lda (R0),y ora Flag4080 sta (R0),y rts rts DISK icon CB6: .byte 33 .byte 165 .byte DSKw,DSKh .word Do0P0 EXIcon: @ EXIw =picW EXIh =picH LAUcon: A LAUw =picW LAUh =picH DSKcon: B DSKw =picW DSKh =picH DRVcon: C DRVw =picW DRVh =picH AROcon: pD AROw =picW AROh =picH FMTcon:  E FMTw =picW FMTh =picH rts MoveCons: ldw R0,#ClickBoxes ldw R1,#THEICONS ldy #$00 10$: lda (R0),y sta (R1),y cwi R0,#EndCon inw R0 inw R1 blt 10$ rts FixOne: ldy #0 lda (R0),y ora Flag4080 sta (R0),y ldy #2 lda (R0),y ora Flag4080 sta (R0),y rts 0P0 AbtBox: jsr ClrScrn AbtBox2: cwi rightMargin,#320 ble 10$ ldb AbtDat+4,#$80 ldb AbtDat+6,#$81 10$: lda #[(AbtDat) sta $02 ; set lsb for dialog data lda #](AbtDat) sta $03 ; set msb for dialog data jmp $c256 ; call DoAbtBox and leave! AbtDat: .byte $01 ; size flag, and shadow pattern .byte $20,$b5,$40,$00,$1e,$01 ; dialog box dimensions .byte $0b,$06,$0b ; static text .word AbtT00 .byte $0b,$06,$17 ; static text .word AbtT01 .byte $0b,$06,$21 ; static text .word AbtT02 .byte $0b,$07,$2a ; static text .word AbtT03 .byte $0b,$07,$35 ; static text .word AbtT04 .byte $0b,$07,$47 ; static text .word AbtT05 .byte $0b,$07,$52 ; static text .word AbtT06 .byte $0b,$07,$5d ; static text .word AbtT07 .byte $0b,$08,$6d ; static text .word AbtT08 .byte $0b,$08,$77 ; static text .word AbtT09 .byte $0b,$08,$81 ; static text .word AbtT0a .byte $01,$12,$7e ; OK button .byte $00 ; end of table AbtT00: .byte $1a,$18," geoBEAP v2.1",27,0 AbtT01: .byte "This program is SHAREWARE. Distribute it",27,0 AbtT02: .byte "as you like. If you enjoy it, send your",27,0 AbtT03: .byte "registration fee of $25 USD to the",27,0 AbtT04: .byte "following address:",27,0 AbtT05: .byte "Bo Zimmerman",27,0 AbtT06: .byte "1907 Cameo Dr.",27,0 AbtT07: .byte "Round Rock, TX 78664",27,0 AbtT08: .byte "Registering this program will entitle you",27,0 AbtT09: .byte "to notification of updates, and encourage",27,0 AbtT0a: .byte "future development.",27,0 27,0 ,1,$81 .byte [(BEA0P0 .ramsect ct XIw =picW EXIh =picH LAUcon: A LAUw =picW LAUh =picH DSKcon: B DSKw =picW DSKh =picH DRVcon: C DRVw =picW DRVh =picH AROcon: pD AROw =picW AROh =picH FMTcon:  E FMTw =picW FMp3|y33f3f33f33f33f͛fy p  ny fͰ f fy f  Ͱy pٞٳٳ?03  h7 كك ك ك6 ك fh`{6l6l6l6l6lpåp     BBpS/2gbRLE&PRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&{F^m8X ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .if Pass1 8X .noeqin .noglbl  .include GEOSequates .eqin .glbl .endif  .psect jmp Go2RLE ; VPRGbase + 0 se + 0 jmp AbtBox ; VPRGbase + 3 s.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod8X0 Go2RLE: cpb SrcDrv,DstDrv bne 10$ jsr i_CNCLBox .word t2txt0 rts 10$: lda PackUnpack beq 11$ jmp Go2Unpack 11$: jmp Go2Pack t2txt0: .byte "Source and Dest. must be different!",27,0 cmp #'B' beq 11$ cmp #'b' bne 18X0 @;**************************************************** Go2Unpack:  lda DstDrv @  jsr SecIOinit cpx #0 beq 10$ jmp DiskError 10$: lda SrcDrv jsr SetDevice jsr GetFirstFile ; get a filename cpx #$00 bne 11$ jmp Co22 11$: jsr i_CNCLBox .word t2NoFile jmp HappyEnd Co2Unpack: lda SrcDrv jsr SetDevice jsr GetNxtFile cpx #$00 beq Co22 jsr i_OKBox .word t2Done jmp HappyEnd Co22: mvw A0,File ; now examine its disk entry mvw File,R6 ldb $886e,#$ff jsr FindFile cpx #0 ; did we find the file? beq 11$ jmp DiskError 11$: ldy #$15 lda (R5),y ; is it sequential type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp HappyEnd 12$: mvw File,A2 ldb A3L,#0 jsr OpenSF ; and open the file cpx #0 beq 13$ 16$: jmp DiskError 13$: ldw A2,#t2Ready jsr  DoNxtD ; confirm the whole process now 8X0 cbi sysDBData,#$03 beq 14$ ; ready to go! jmp HappyEnd 14$: jmp DoUnRLE t2Done: .byte $18,"Operation Complete",27,0 t2NoFile: .byte $18,"Select a file to unpack.",27,0 t2BadFile: .byte $18,"File is not a .RLE image!",27,0 t2Ready: .byte $18,"Ready to unpack .RLE image?",27,0 18,"File is not a .D64 image!",27,0 s not a .D64 image!",27,0 ,0 ,0 H h e e8X0 DoUnRLE: ldb TRACK,#1 ldb SECTOR,#0 sta TrksDone 11$: ldw LastMem,#$6000 jsr UnRLE ; RLE data -> track buffer stx LastError cpx #0 beq 15$ cpx #11 beq 15$ jmp DiskError 14$: jsr Imprint jmp Co2Unpack ; happy exit 15$: mvw TRACK,TNSTRACK jsr TnSBar mvw LastMem,A3 ldw LastMem,#$6000 ldw A2,#$6000 lda LastError bne 17$ dew A3 17$: jsr WriteSecs cpx #0 bne 13$ lda LastError beq 11$ bne 16$ 13$: cpx #$28 bge 16$ jmp DiskError 16$: jsr Imprint jmp Co2Unpack ; happy exit sr FindFile cpx #0 ; did we find the file? beq 11$ jmp DiskError 11$: ldy #$15 lda (R5),y ; is it sequential type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp ShowSrc 12$: mvw File,A2 ldb A3L,#0 jsr OpenSF ; and op8X0 UnRLE: 10$: jsr GetSByte cpx #0 beq 11$ rts 11$: sta RLEcode cmp #$81 bcs 20$ 12$: mvw LastMem,A3 jsr GetSByte ; worry about EOF???!!! ldy #0 sta (A3),y inw LastMem cpx #0 beq 13$ rts 13$: dec RLEcode bne 12$ cwi LastMem,#$7800 blt 10$ ldx #0 rts 20$: lda RLEcode ; start repeat state and #$7f ; by decreasing by $80 sta RLEcode jsr GetSByte sta RLEbyte 21$: mvw LastMem,A3 ldy #0 lda RLEbyte sta (A3),y inw LastMem dec RLEcode bne 21$ cpx #0 beq 22$ rts 22$: cwi LastMem,#$7800 bge 23$ jmp UnRLE 23$: ldx #0 rts jmp UnRLE 23$: ldx #0 rts rts rts rts jmp UnRLE 23$: ldx #0 rts ? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp ShowSrc 12$: mvw File,A2 ldb A3L,#0 jsr OpenSF ; and op8X0 @;**************************************************** Go2Pack: lda SrcDrv jsr SecIOinit cpx #0 beq 10$ jmp DiskError 10$: ldw A4,#FileName  lda #12 8X0 jsr GetFilename bne 11$ 99$ rts 11$: lda FileName beq 99$ 12$: jsr ChkOkPack bne 99$ jsr FixFNam lda DstDrv jsr SetDevice jsr OpenDisk ldw A2,#FileName ldb A3L,#$02 jsr CreatSF cpx #0 beq 13$ jmp DiskError 13$: jmp DoPakRLE w LastMem dec RLEcode bne 21$ cpx #0 beq 28X0 ; ** check to see if the source drive can be packed ChkOkPack: lda SrcDrv jsr DriveST sta DrvType cmp #1 ; 1541 drive beq 10$ cmp #2 ; 1571 drive bne 16$ lda SrcDrv jsr SetDevice ldw R4,#$6000 ldb R1L,#40 ldb R1H,#0 jsr GetBlock cpx #0 beq 11$ ldb DrvType,#1 bra 10$ 16$: cmp #3 ; 1581 drive beq 12$ ldw A4,#660 ; "cmd" drive ldb DrvType,#'C' bra 13$ 10$: ldw A4,#500 ; .D64 ldb DrvType,#36 bra 13$ 11$: ldw A4,#1000 ; .D71 ldb DrvType,#71 bra 13$ 12$: ldw A4,#2500 ; .D81 ldb DrvType,#81 13$: lda DstDrv jsr SetDevice jsr GetDirHead ldw R5,#$8200 jsr CalcBlksFree cpw R4,A4 blt 15$ ldx #0 99$: rts 15$: jsr i_CNCLBox .word t2NoBlks ldx #1 rts t2NoBlks: .byte $18,"Not enough space on dest.",27,0 gh space on dest.",27,0 ZfillZ: ldy #0 ; clear index to ZUnBuf lda C ; is thing a code? bne 10$ lda C+1 ; no, so push char bra 12$ 10$: ldx C+1 ; check for kwkwk case cpx Tndx bne 13$ lda W+1 ; yes, so fetch last thing ldx W ; was last 8X0 FixFNam: ldw A0,#FileName 10$: ldy #0 lda (A0),y beq 16$ cmp #'.' bne 15$ inw A0 lda (A0),y beq 16$ cmp #'R' beq 11$ cmp #'r' bne 15$ 11$: rts 15$: inw A0 bra 10$ rts 16$: ldw A4,#t2fnExt ; needs extension 17$: lda (A4),y ; copy extension sta (A0),y beq 11$ iny bne 17$ rts t2fnExt: .byte ".RLE",0 FileName,#0 ldw R0,#t2fnBox ldw A4,#FileName jsr DoDlgBox cbi sysDBData,#2 rts t2fnBox: .byte $80|$01 .byte 11 .byte $12,$19 .word t2fnBtx1 .byte 13 .8X0 DoPakRLE: ldb TRACK,#1 ldb SECTOR,#0 10$: mvw TRACK,TNSTRACK jsr TnSBar ldw A2,#$6000 mvw A2,LastTnS ldw A3,#$77ff jsr ReadSecs mvw A2,LastBlk stx LastError mvw TRACK,TNSTRACK jsr TnSBar ldx LastError cpx #0 beq 13$ cpx #2 beq 13$ cpx #11 beq 13$ cpx #$ff beq 13$ 12$: jmp DiskError 13$: jsr DoRLE ; dump rest of buffer bne 12$ lda LastError beq 10$ ldb A2L,#130 jsr ClosSF jsr Imprint jsr i_OKBox .word t2Done  jmp HappyEnd owDst e jsr NewDst 8X0 DoRLE: ldb BufOffset,#0 mvw LastTns,A2 ldw A3,#RLEbuf 44$: ldb Repeats,#0 ldy BufOffset lda (A2),y ldy #1 sta (A3),y sty RLEcode sty RLEoffset inc BufOffset beq 55$ jsr RLEloop beq 44$ 55$: ldy #0 lda RLEcode sta (A3),y inc RLEoffset adw RLEoffset,A3 mvw A2,LastTns ldw A2,#RLEbuf dew A3 jsr PutSMem cpx #0 beq 10$ rts 10$: inc LastTns+1 cpw LastTns,LastBlk blt 11$ ldx #0 rts 11$: jmp DoRLE t t2fnBtx1 .byte 13 .byte $28 .byte $34 .byte A4 .8X0 RLEloop: ldy BufOffset ; now read next character bne 10$ ldx #1 ; done with block rts 10$: inc BufOffset ; ALWAYS increment read character lda (A2),y ; store it in... ldy RLEoffset iny sta (A3),y ; NEXT rle position dey cmp (A3),y ; and compare it to previous beq 50$ ; this will mean a repetition ldb Repeats,#0 cbi RLEcode,#$80 ; NONREPETITION cases. repeating NOW? bge 20$ ; yes, so end the repetition cmp #$80 ; have we filled nonrepetition cases? beq 20$ ; if yes, then go start a new one inc RLEoffset ; still nonrepeating, prepare next RLE inc RLEcode ; and increment RLE nonrep counter jmp RLEloop ; and go for more 20$: ldy #0 ; NOW, end nonrep by writing lda RLEcode ; out the current RLE code counter sta (A3),y dec BufOffset ; forget we read this inc RLEoffset adw RLEoffset,A3 ; update the RLEbuffer pointer  ldx #0 ; more INPUT rts  50$: inc Repeats 8X0 cbi RLEcode,#$80 ; are we full of nonrepetitions? beq 20$ cmp #$81 ; REPETITION cases, repeating now? bcc 55$ ; no, so convert it.. cmp #$ff ; repeating, but too many? beq 20$ inc RLEcode ; increment the counter jmp RLEloop ; and continue 55$: cmp #$01 ; we have more than one nonrep? bne 57$ 56$: lda RLEcode ; only one nonrep, so easy! add #$81 ; add one, and make REPEATING sta RLEcode ; to convert to repetition jmp RLEloop ; and go get some more 51$: bra 20$ 57$: cmp #$02 ; have we seen three now? bne 59$ ; no, so keep going... lda Repeats ; two or more, but num repeats? cmp #2 bcs 56$ ; two chars but all repeats! yeah! 58$: inc RLEoffset ; still nonrepeating, prepare next RLE inc RLEcode ; and increment RLE nonrep counter jmp RLEloop ; and go for more 59$: lda Repeats cmp #2 bcc 58$ dec RLEcode ; forget your last character dec RLEcode dec RLEoffset dec RLEoffset dec BufOffset ; even the one you read (first repeat) dec BufOffset bra 51$ ; and close/restart as normal rmal PgPa0 ~hhG H HGI8X0 .ramsect File: .block 2 BytesWritten: .block 2 TrksDone: .block 1 DrvType: .block 1 DrvMax: .block 1 LastError: .block 1 OtherLast: .block 1 ProgOffset: .block 1 LastBlk: .block 2 LastTnS: .block 2 LastMem: .block 2 RLEcode: .block 1 RLEbyte: .block 1 Repeats: .block 2 BufOffset: .block 2 RLEOffset: .block 2 RLEbuf: .block 512 Ecode,#$80 ; NONREPETITION cases. repeating NOW? bge 20$ ; yes, so end the repetition cmp #$80 ; have we filled nonrepetition cases? beq 20$ ; S/3gbRLEi-PRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&{n F7}8X ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .if Pass1 8X .noeqin .noglbl  .include GEOSequates .eqin .glbl .endif  .psect jmp Go2RLE ; VPRGbase + 0 se + 0 jmp AbtBox ; VPRGbase + 3 s.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod8X0 Go2RLE: cpb SrcDrv,DstDrv bne 10$ jsr i_CNCLBox .word t2txt0 rts 10$: lda PackUnpack beq 11$ jmp Go2Unpack 11$: jmp Go2Pack t2txt0: .byte "Source and Dest. must be different!",27,0 27,0 $A D :`W8X0 @;**************************************************** Go2Unpack:  lda DstDrv @  jsr SecIOinit cpx #0 beq 10$ jmp DiskError 10$: lda SrcDrv jsr SetDevice jsr GetFirstFile ; get a filename cpx #$00 bne 11$ jmp StartUnRLE 11$: jsr i_CNCLBox .word t2NoFile  jmp HappyEnd  Co2Unpack: lda SrcDrv 8X0 jsr SetDevice jsr GetNxtFile cpx #$00 bne 10$ jmp StartUnRLE 10$: jsr i_OKBox .word t2Done jmp HappyEnd ldb $886e,#$ff jsr Fi8X0 StartUnRLE: mvw A0,File mvw A0,FnamPtr ldb TRACK,#1 ldb SECTOR,#0 sta TrksDone jsr UnFixFile beq 10$ jmp HappyEnd 10$: ldw A2,#t2Ready jsr  DoNxtD ; confirm the whole process now 8X0 cbi sysDBData,#$03 beq 14$ ; ready to go! jmp HappyEnd 14$: nop ContUnRLE: lda SrcDrv jsr SetDevice jsr OpenDisk jsr FixFNam2 10$: mvw FnamPtr,R6 ldb $886e,#$ff jsr FindFile cpx #0 ; did we find the file? beq 11$ jsr Imprint jsr i_OKCANBox ; confirm the next source .word t2NewSrc cbi sysDBData,#$01 beq 10$ ; ready to go! jmp HappyEnd 11$: ldy #$15 lda (R5),y ; is it sequential type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp HappyEnd 12$: mvw FnamPtr,A2 ldb A3L,#0 jsr OpenSF ; and open the file cpx #0 beq 13$ 16$: jmp DiskError 13$: jsr DoUnRLE bne 15$ jmp ContUnRLE 15$: cpx #1 bne 17$ jsr Imprint jmp Co2Unpack 17$: jmp HappyEnd t2Done: .byte $18,"Operation Complete",27,0 t2NoFile: .byte $18,"Select a file to unpack.",27,0 t2BadFile: .byte $18,"File is not first 1-image!",27,0 t2Ready: .byte $18,"Ready to unpack .RLE images?",27,0 t2NewSrc: .byte $18,"Insert next volume disk.",27,0 ge!",27,0 s not a .D64 image!",27,0 ,0 ,0 H h e e8X0 UnFixFile: mvw FnamPtr,A2 ldw A3,#FileName+2 ldy #0 10$: lda (A2),y sta (A3),y beq 11$ iny bne 10$ 11$: lda FileName+3 cmp #'-' bne 14$ 13$: lda FileName+2 cmp #'1' beq 15$ 14$: jsr i_CNCLBox .word  t2BadFile 8X0 ldx #$ff rts 15$: ldb FileName+2,#'0' ldw FnamPtr,#FileName+2 ldx #0 rts FixFNam2 10$: mvw FnamPtr,R6 ldb $886e,#$ff jsr FindFile cpx #0 ; did we find the file? beq 11$ jsr Imprint jsr i_OKCANBox ; confirm the ne8X0 DoUnRLE: 11$: ldw LastMem,#$6000 jsr UnRLE ; RLE data -> track buffer stx LastError cpx #0 beq 15$ cpx #11 beq 15$ jmp DiskError 15$: mvw TRACK,TNSTRACK jsr TnSBar mvw LastMem,A3 ldw LastMem,#$6000 ldw A2,#$6000 lda LastError bne 17$ dew A3 17$: jsr WriteSecs cpx #0 bne 13$ lda LastError beq 11$ mvw TRACK,R1 ldw R4,#$6000 jsr GetBlock cpx #0 bne 16$ ldx #0 ; next file exit rts 13$: cpx #$28 bge 16$ jmp DiskError ; error exit 16$: ldx #1 ; complete exit rts exit rts rts rts bge 23$ jmp UnRLE 23$: ldx #0 rts dy #$15 lda (R5),y ; is it sequential type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp HappyEnd 12$: mvw FnamPtr,A2 ldb A3L,#0 jsr OpenSF ; and open the file cpx #08X0 UnRLE: 10$: jsr GetSByte cpx #0 beq 11$ rts 11$: sta RLEcode cmp #$81 bcs 20$ 12$: mvw LastMem,A3 jsr GetSByte ; worry about EOF???!!! ldy #0 sta (A3),y inw LastMem cpx #0 beq 13$ rts 13$: dec RLEcode bne 12$ cwi LastMem,#$7800 blt 10$ ldx #0 rts 20$: lda RLEcode ; start repeat state and #$7f ; by decreasing by $80 sta RLEcode jsr GetSByte sta RLEbyte 21$: mvw LastMem,A3 ldy #0 lda RLEbyte sta (A3),y inw LastMem dec RLEcode bne 21$ cpx #0 beq 22$ rts 22$: cwi LastMem,#$7800 bge 23$ jmp UnRLE 23$: ldx #0 rts jmp UnRLE 23$: ldx #0 rts rts rts rts jmp UnRLE 23$: ldx #0 rts ? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp ShowSrc 12$: mvw File,A2 ldb A3L,#0 jsr OpenSF ; and op8X0 @;**************************************************** Go2Pack: lda SrcDrv jsr SecIOinit cpx #0 beq 10$ jmp DiskError 10$: ldw A4,#FileName+4  lda #8 8X0 jsr GetFilename  bne 11$ 8X099$ rts 11$: lda FileName+4 beq 99$ 12$: jsr ChkOkPack bne 99$ jsr FixFNam 13$: ldb TRACK,#1 ldb SECTOR,#0 jmp DoPakiRLE : mvw LastMem,A3 ldy #0 lda RLEbyte sta (A3),y inw LastMem dec RLEcode bne 21$ cpx #0 beq 28X0 DoPakiRLE: 10$: ldb BlkCounter,#0 lda DstDrv jsr SetDevice jsr OpenDisk mvw FnamPtr,A2 ldb A3L,#$02 jsr CreatSF cpx #0 beq 13$ jmp DiskError 13$: jsr DoPakRLE cpx #$ff ; error exit? bne 15$ rts 15$: cpx #1 ; finished exit? bne 16$ ldb A2L,#130 jsr ClosSF cpx #0 bne 99$ jsr NxtFile beq 10$ cpx #$ff bne 99$ rts 16$: ldb A2L,#130 jsr ClosSF jsr Imprint jsr i_OKBox .word t2Done  jmp HappyEnd  99$: jmp DiskError c RLEcode bne 21$ cpx #0 beq 28X0 ; ** check to see if the source drive can be packed ChkOkPack: lda DstDrv jsr SetDevice jsr GetDirHead ldw R5,#$8200 jsr CalcBlksFree cwi R4,#230 blt 15$ ldx #0 99$: rts 15$: jsr i_CNCLBox .word t2NoBlks ldx #1 rts t2NoBlks: .byte $18,"Not enough space on dest.",27,0 NxtFile: jsr FixFNam2 lda DstDrv jsr SetDevice jsr GetDirHead ldw R5,#$8200 jsr CalcBlksFree cwi R4,#230 blt 15$ ldx #0 99$: rts 15$: jsr Imprint  jsr i_OKCANBox 8X0 .word t2NxtDsk cbi sysDBData,#$01 beq 16$ ldx #$ff rts 16$: jsr OpenDisk cpx #0 rts FixFNam2: lda FileName+2 cmp #'9' bge 20$ inc FileName+2 rts 20$: ldb FileName+2,#'0' cwi FnamPtr,#(FileName+2) blt 21$ ldw FnamPtr,#(FileName+1) 21$: lda FileName+1 cmp #'9' bge 22$ inc FileName+1 rts 22$: ldb FileName+1,#'0' cwi FnamPtr,#(FileName+1) blt 23$ ldw FnamPtr,#FileName 23$: inc FileName rts t2NxtDsk: .byte $18,"Destination full. Insert next.",27,0 inc FileName+2 rts 20$: ld8X0 FixFNam: ldw A0,#FileName+4 10$: ldy #0 lda (A0),y beq 16$ cmp #'.' bne 15$ inw A0 lda (A0),y beq 16$ cmp #'R' beq 11$ cmp #'r' bne 15$ 11$: rts 15$: inw A0 bra 10$ rts 16$: ldw A4,#t2fnExt ; needs extension 17$: lda (A4),y ; copy extension sta (A0),y beq 18$ iny bne 17$ 18$: ldw A4,#t2fnPre ldw A0,#FileName ldy #0 19$: lda (A4),y beq 20$ sta (A0),y iny bne 19$ 20$: ldw FnamPtr,#FileName+2 rts t2fnExt: .byte ".RLE",0 t2fnPre: .byte "001-",0 .word 8X0 DoPakRLE: mvw TRACK,TNSTRACK jsr TnSBar cbi BlkCounter,#8 blt 11$ ldx #1 rts 11$: ldw A2,#$6000 mvw A2,LastTnS ldw A3,#$77ff ;cbi BlkCounter,#8 ;blt 13$ ;ldw A3,#$60ff 13$: inc BlkCounter jsr ReadSecs mvw A2,LastBlk stx LastError  mvw TRACK,TNSTRACK  jsr TnSBar 8X0 ldx LastError cpx #0 beq 16$ cpx #2 beq 16$ cpx #11 beq 16$ cpx #$ff beq 16$ 15$: jsr DiskError ldx #$ff rts 16$: jsr DoRLE ; dump rest of buffer bne 15$ lda LastError bne 17$ jmp DoPakRLE 17$: ldx #0 rts FixFNam2: lda FileName+2 cmp #'9' bge 20$ inc FileName+2 rts 20$: ldb FileName+2,#'0' cwi FnamPtr,#(FileName+2) blt 21$ ldw FnamPtr,#(FileName+1) 21$: lda FileName+1 cmp #'9' bge 22$ inc F8X0 DoRLE: ldb BufOffset,#0 mvw LastTns,A2 ldw A3,#RLEbuf 44$: ldb Repeats,#0 ldy BufOffset lda (A2),y ldy #1 sta (A3),y sty RLEcode sty RLEoffset inc BufOffset beq 55$ jsr RLEloop beq 44$ 55$: ldy #0 lda RLEcode sta (A3),y inc RLEoffset adw RLEoffset,A3 mvw A2,LastTns ldw A2,#RLEbuf dew A3 jsr PutSMem cpx #0 beq 10$ rts 10$: inc LastTns+1 cpw LastTns,LastBlk blt 11$ ldx #0 rts 11$: jmp DoRLE 15$: jsr DiskError ldx #$ff rts 16$: jsr DoRLE ; dump 8X0 RLEloop: ldy BufOffset ; now read next character bne 10$ ldx #1 ; done with block rts 10$: inc BufOffset ; ALWAYS increment read character lda (A2),y ; store it in... ldy RLEoffset iny sta (A3),y ; NEXT rle position dey cmp (A3),y ; and compare it to previous beq 50$ ; this will mean a repetition ldb Repeats,#0 cbi RLEcode,#$80 ; NONREPETITION cases. repeating NOW? bge 20$ ; yes, so end the repetition cmp #$80 ; have we filled nonrepetition cases? beq 20$ ; if yes, then go start a new one inc RLEoffset ; still nonrepeating, prepare next RLE inc RLEcode ; and increment RLE nonrep counter jmp RLEloop ; and go for more 20$: ldy #0 ; NOW, end nonrep by writing lda RLEcode ; out the current RLE code counter sta (A3),y dec BufOffset ; forget we read this inc RLEoffset adw RLEoffset,A3 ; update the RLEbuffer pointer  ldx #0 ; more INPUT rts  50$: inc Repeats 8X0 cbi RLEcode,#$80 ; are we full of nonrepetitions? beq 20$ cmp #$81 ; REPETITION cases, repeating now? bcc 55$ ; no, so convert it.. cmp #$ff ; repeating, but too many? beq 20$ inc RLEcode ; increment the counter jmp RLEloop ; and continue 55$: cmp #$01 ; we have more than one nonrep? bne 57$ 56$: lda RLEcode ; only one nonrep, so easy! add #$81 ; add one, and make REPEATING sta RLEcode ; to convert to repetition jmp RLEloop ; and go get some more 51$: bra 20$ 57$: cmp #$02 ; have we seen three now? bne 59$ ; no, so keep going... lda Repeats ; two or more, but num repeats? cmp #2 bcs 56$ ; two chars but all repeats! yeah! 58$: inc RLEoffset ; still nonrepeating, prepare next RLE inc RLEcode ; and increment RLE nonrep counter jmp RLEloop ; and go for more 59$: lda Repeats cmp #2 bcc 58$ dec RLEcode ; forget your last character dec RLEcode dec RLEoffset dec RLEoffset dec BufOffset ; even the one you read (first repeat) dec BufOffset bra 51$ ; and close/restart as normal rmal PgPa0 ~hhG H HGI8X0 .ramsect File: .block 2 FnamPtr: .block 2 BlkCounter: .block 2 TrksDone: .block 1 DrvType: .block 1 DrvMax: .block 1 LastError: .block 1 OtherLast: .block 1 ProgOffset: .block 1 LastBlk: .block 2 LastTnS: .block 2 LastMem: .block 2 RLEcode: .block 1 RLEbyte: .block 1 Repeats: .block 2 BufOffset: .block 2 RLEOffset: .block 2 RLEbuf: .block 512 PETITION cases. repeating NOW? bge 20$ ; yes, so end the repetition cmp #$80 ; have we filled nonrepetition cases? beq 20$ ; S/4gbD64iPRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&~AE8X ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .if Pass1 8X .noeqin .noglbl  .include GEOSequates .eqin .glbl .endif  .psect jmp Go2647181 ; VPRGbase + 0 + 0 jmp AbtBox ; VPRGbase + 3 s.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod8X0 Go2647181: cpb SrcDrv,DstDrv bne 10$ jsr i_CNCLBox .word t2txt0 rts 10$: lda PackUnpack beq 11$ jmp Go2Unpack 11$: jmp Go2Pack t2txt0: .byte "Source and Dest. must be different!",27,0 27,0 xtFile cpx #$00 beq Co22 8X0 Go2Pack: lda SrcDrv jsr SecIOinit cpx #0 beq 10$ jmp FError 10$: ldw A4,#FileName  lda #12 8X0 jsr GetFilename  bne 11$ 8X099$ rts 11$: lda FileName beq 99$ 12$: jsr ChkOkPack bne 99$ jsr FixFNam lda DstDrv jsr SetDevice jsr OpenDisk ldw A2,#FileName ldb A3L,#$02 jsr CreatSF cpx #0 beq 13$ jmp FError 13$: jmp DoPakD64 D64 D64 byte $02,$0f,$44 .byte 0 t2fnBtx1: .byte $18,"Enter destination file:",8X0 DoPakD64: ldb TRACK,#1 ldb SECTOR,#0 mvw TRACK,TNSTRACK jsr TnSBar 16$: ; no need to set src. secio will ldw A2,#$6000 ldw A3,#$77ff 17$: jsr ReadSecs stx LastError mvw TRACK,TNSTRACK jsr TnSBar ; NOW BEGIN WRITE PROCESS lda DstDrv jsr SetDevice ;************* jsr OpenDisk mvw A2,A3 ; from read...,should be $77ff dew A3 ; because it will be one beyond ldw A2,#$6000 jsr PutSMem cpx #0 ; any dest error at all? bne 20$ lda LastError ; is there more to get? beq 16$ cmp #2 beq 21$ ; if error other than t&s, exit cmp #$ff beq 21$ ; end of disk error 20$: jmp DiskError 21$: ldb A2L,#130 jsr ClosSF jsr Imprint jsr i_OKBox .word t2Done 22$: jmp HappyEnd owDst : jsr NewDst jmp ShowDst st st .8X0 Go2Unpack: lda DstDrv jsr SecIOinit cpx #0 beq 10$ jmp FError 10$: lda SrcDrv jsr SetDevice jsr GetFirstFile ; get a filename cpx #$00 bne 11$ jmp Co22 11$: jsr i_CNCLBox .word t2NoFile jmp HappyEnd Co2Unpack: lda SrcDrv jsr SetDevice jsr GetNxtFile cpx #$00 beq Co22 jsr Imprint jsr i_OKBox .word t2Done jmp HappyEnd Co22: mvw A0,File ; now examine its disk entry mvw File,R6 ldb $886e,#$ff jsr FindFile cpx #0 ; did we find the file? beq 11$ jmp DiskError 11$: ldy #$15 lda (R5),y ; is it sequential type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp HappyEnd 12$: jsr GetD64Type ; examine the file extension jsr ChkD64Type ; now check the dest drive beq 13$ ; if the dont match jmp HappyEnd 13$: jsr T2ReadyYN jsr  DoNxtD ; confirm the whole process now 8X0 cbi sysDBData,#$03 beq 14$ ; ready to go! jmp HappyEnd 14$: lda SrcDrv ; now open the source disk jsr OpenDisk mvw File,A2 ldb A3L,#0 jsr OpenSF ; and open the file cpx #0 beq 15$ jmp DiskError 15$: jmp DoUnD64 t2Done: .byte $18,"Operation Complete",27,0 t2NoFile: .byte $18,"Select a file to unpack.",27,0 t2BadFile: .byte $18,"File is not a .D64 image!",27,0 8X0 DoUnD64: ldb TRACK,#1 ldb SECTOR,#0 16$: lda SrcDrv jsr SetDevice ldw A2,#$6000 ldw A3,#$77ff jsr GetSMem stx LastError cpx #0 beq 18$ cpx #11 beq 18$ cpx #$ff beq 18$ 17$: jmp DiskError 18$: mvw TRACK,TNSTRACK  jsr TnSBar 8X0 ; no need to set dest. secio will mvw A2,A3 ; from read...,should be $77ff ldw A2,#$6000 19$: jsr WriteSecs cpx #$ff beq 99$ cpx #0 ; any dest error at all? bne 17$ lda LastError ; is there more to get? beq 16$ 99$: jsr Imprint ; happy exit jmp Co2Unpack ; equential type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp ShowSrc 12$: jsr GetD64Type ; examine the file extension jsr ChkD64Type ; now check the dest drive beq 13$ ; if 8X0 GetD64Type: ldb D64Type,#1 ldy #$ff 13$: iny lda (A0),y bne 13$ dey dey dey dey lda (A0),y cmp #'.' beq 14$ rts 14$: iny lda (A0),y cmp #'d' beq 15$ cmp #'D' beq 15$ rts 15$: iny iny lda (A0),y cmp #'1' beq 17$ cmp #'4' bne 16$ dey lda (A0),y cmp #'6' bne 16$ ldb D64Type,#1 16$: rts 17$: dey lda (A0),y cmp #'7' bne 18$ ldb D64Type,#2 rts 18$: cmp #'8' bne 19$ ldb D64Type,#3 rts 19$: rts T2ReadyYN: ldw A2,#t2ReadyU lda D64Type cmp #1 bne 10$ 99$: ldb t2ReadyU+19,#'6' ldb t2ReadyU+20,#'4' rts 10$: cmp #2 bne 11$ ldb t2ReadyU+19,#'7' ldb t2ReadyU+20,#'1' rts 11$: cmp #3 bne 99$ ldb t2ReadyU+19,#'8' ldb t2ReadyU+20,#'1' rts t2ReadyU: .byte $18,"Ready to unpack .D64 file?",27,0 jsr YNBox ; confirm the whole process now cbi sysDBData,#$03 beq 14$ ; ready to go! jmp ShowSrc 14$: lda SrcDrv ; now open the source disk jsr OpenDisk mvw File,A2 ldb A3L,#0 jsr OpenSF ; and open the file cpx #0 beq 15$ jsr FError ; an ope8X0 ChkD64Type: lda DstDrv jsr DriveST cmp D64Type beq 14$ cmp #3 bge 13$ cbi D64Type,#1 beq 14$ 13$: dec D64Type lda D64Type asl a tay lda t2Nottab,y sta A2L lda t2Nottab+1,y sta A2H jsr CNCLBox ldx #$ff rts 14$: ldx #0 rts  t2Not41: .byte $18,"Dest. Drive must be a 1541/1571.",27,0 t2Not71: .byte $18,"Dest. Drive must be a 1571",27,0 t2Not81: .byte $18,"Dest. Drive must be a 1581",27,0 t2Nottab: .word t2Not41,t2Not71,t2Not81,0 13$: t2NoFile: .byte $18,"8X0 ; ** check to see if the source drive can be packed ChkOkPack: lda SrcDrv jsr DriveST sta D64Type cmp #1 ; 1541 drive beq 10$ cmp #2 ; 1571 drive bne 16$ lda SrcDrv jsr SetDevice ldw R4,#$6000 ldb R1L,#40 ldb R1H,#0 jsr GetBlock cpx #0 beq 11$ ldb D64Type,#1 bra 10$ 16$: cmp #3 ; 1581 drive beq 12$ jsr i_CNCLBox .word t2NoDSup ldx #1 rts 10$: ldw A4,#690 ; .D64 ldw D64TypW,#t2fnTyp1 bra 13$ 11$: ldw A4,#1378 ; .D71 ldw D64TypW,#t2fnTyp2 bra 13$ 12$: ldw A4,#3230 ; .D81 ldw D64TypW,#t2fnTyp3 13$: lda DstDrv jsr SetDevice jsr GetDirHead ldw R5,#$8200 jsr CalcBlksFree cpw R4,A4 blt 15$ ldx #0 rts 15$: jsr i_CNCLBox .word t2NoBlks ldx #1 rts t2NoDSup: .byte $18,"Drive type not supported.",27,0 t2NoBlks: .byte $18,"Not enough space on dest.",27,0 t2fnTyp1: .byte ".D64",0 t2fnTyp2: .byte ".D71",0 t2fnTyp3: .byte ".D81",0 urce disk jsr OpenDisk mvw File,A2 ldb A3L,#0 jsr OpenSF ; and open the file cpx #0 beq 15$ jsr FError ; an ope8X0 FixFNam: ldw A0,#FileName 10$: ldy #0 lda (A0),y beq 16$ cmp #'.' bne 15$ inw A0 lda (A0),y beq 16$ cmp #'D' beq 11$ cmp #'d' bne 15$ 11$: rts 15$: inw A0 bra 10$ rts 16$: mvw D64TypW,A4 ; needs extension 17$: lda (A4),y ; copy extension sta (A0),y beq 11$ iny bne 17$ rts 8X0 DiskError: txa pha jsr imprint pla tax jsr FError jsr NewSrc jsr ShowSrc jsr NewDst jmp ShowDst cmp #'d' bne 15$ 11$: rts 18X0 .ramsect File: .block 2 D64Type: .block 1 D64TypW: .block 2 LastError: .block 1 ProgOffset: .block 1 LastTnS: .block 2 LastMem: .block 2ck 25$ 11$: rts 15$: inw A0 bra 10$ rts 16$: mvw D64TypW,A4 ; needs extension 17$: S/5gbBEAPi?PRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&|:K_7^qoZ8X ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .if Pass1 8X .noeqin .noglbl  .include GEOSequates .eqin .glbl .endif  .psect jmp Go2BEAP ; VPRGbase + 0 0 + 0 jmp AbtBox ; VPRGbase + 3 s.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod8X0 Go2BEAP: cpb SrcDrv,DstDrv bne 10$ jsr i_CNCLBox .word t2txt0 rts 10$: lda PackUnpack beq 11$ jmp Go2Unpack 11$: jmp Go2Pack t2txt0: .byte "Source and Dest. must be different!",27,0 2Done: .byte $18,"Operation Comple8X0 @;**************************************************** Go2Unpack:  lda DstDrv @  jsr SecIOinit cpx #0 beq 10$ jmp DiskError 10$: lda SrcDrv jsr SetDevice jsr GetFirstFile ; get a filename cpx #$00 bne 11$ jmp Co22 11$: jsr i_CNCLBox .word t2NoFile jmp HappyEnd Co2Unpack: lda SrcDrv jsr SetDevice jsr GetNxtFile cpx #$00 beq Co22 jsr i_OKBox .word t2Done jmp HappyEnd Co22: mvw A0,File ; now examine its disk entry mvw File,R6 ldb $886e,#$ff jsr FindFile cpx #0 ; did we find the file? beq 11$ jmp DiskError 11$: ldy #$15 lda (R5),y ; is it sequential type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp HappyEnd 12$: mvw File,A2 ldb A3L,#0 jsr OpenSF ; and open the file cpx #0 beq 15$ 16$: jmp DiskError 15$: jsr ChkBEPType ; now check the dest drive beq 13$ ; if the dont match cpx #0 bne 16$ jmp HappyEnd 13$: ldw A2,#t2Ready jsr  DoNxtD ; confirm the whole process now 8X0 cbi sysDBData,#$03 beq 14$ ; ready to go! jmp HappyEnd 14$: jmp DoUnBEP t2Done: .byte $18,"Operation Complete",27,0 t2NoFile: .byte $18,"Select a file to unpack.",27,0 t2BadFile: .byte $18,"File is not a .BEP image!",27,0 t2Ready: .byte $18,"Ready to unpack .BEP image?",27,0 I JI8 Š wŠ`Lw  `HH 8hh,0`HHHHH hh tŠH h8LLw 0`Linker .dbg V1.08X0 ChkBEPType: lda DstDrv ; get actual dest disk blocks jsr SetDevice jsr OpenDisk cpx #0 beq 10$ ; got open disk rts 10$: jsr CMDSet ; now get actual dest disk blocks sta Temp ; and store them in temp lda DstDrv jsr DriveST sta Temp+2 ; actual drive type jsr GetSByte ; and now get first file byte cmp #36 bne 15$ cbi Temp+2,#2 ble 99$ ldw A2,#t2Not41 jmp ChkBEPBad 15$: cmp #71 bne 20$ cbi Temp+2,#2 beq 99$ ldw A2,#t2Not71 jmp ChkBEPBad 20$: cmp #81 bne 25$ cbi Temp+2,#3 bne 22$ 99$: ldx #0 rts 22$: ldw A2,#t2Not81 jmp ChkBEPBad 25$: cmp #'C' beq 30$ ldw A2,#t2NotANY jmp ChkBEPBad 30$: cbi Temp+2,#4 bge 35$ ldw A2,#t2NotCMD jmp ChkBEPBad 35$: jsr GetSByte ; and now get second file byte cmp Temp beq 99$ jsr i_YNBox ; no, so ask them nicely .word t2NotBlks ldx #0 cbi sysDBData,#$03 rts ChkBEPBad: jsr CNCLBox 98$: ldx #0 cpx #$ff rts t2Not41: .byte $18,"Dest. Drive must be a 1541/1571.",27,0 t2Not71: .byte $18,"Dest. Drive must be a 1571",27,0 t2Not81: .byte $18,"Dest. Drive must be a 1581",27,0 t2NotCMD: .byte $18,"Incorrect dest drive type.",27,0 t2NotANY: .byte $18,"File is not in BEP format.",27,0 t2NotBlks: .byte $18,"Diff. partition sizes. Continue?",27,0 .byte $18,"Ready to unp8X0 DoUnBEP: lda #0 ; check THIS out? eh? sta Oflow ; init overflow byte sta Tndx ; init LZW table index sta LZW1st ; init 1st char flag? sta ZUnBuf ; init output buf #1 index sta SECTOR sta LastError ldb TRACK,#1 ldb ZIbit,#8 ; init bits to push ldw ZObyte,#$6000 ; init output pointer? 10$: jsr Read2Buf ; fill LZW buffer w/ data beq 11$ cpx #11 ; EOF ok beq 11$ jmp DiskError 11$: jsr UnLZW ; LZW -> track buffer bne 12$ ; need more input, not op lda LastError beq 10$ 12$: mvw TRACK,TNSTRACK  jsr TnSBar 8X0 mvw ZObyte,A3 ldw ZObyte,#$6000 ldw A2,#$6000 dew A3 @  jsr WriteSecs cpx #0 bne 13$ lda LastError beq 11$ lda Oflow beq 11$ bne 14$ 13$: cpx #$28 bge 14$ jmp DiskError 14$: jsr Imprint jmp Co2Unpack ; happy exit 2NotBlks ldx #0 cbi sysDBData,#$03 rts ChkBEPBad: jsr CNCLBox 98$: ldx #0 cpx #$ff rts t2Not41: .byte $18,"Dest. Drive must be a 1541/1571.",27,0 t2Not71: .byte $18,"Dest. Drive must be a 1578X0 Read2Buf: ldw ZIbyte,#ZIbuf ; init input pointer lda Oflow ; skip overflow byte beq 10$ ldb Oflow,#0 ; clear overflow again mvw ZIlimit,A0 ldy #0 lda (A0),y ; move last byte as 1st sta ZIbuf ldw A0,#ZIbuf+1 ; point ahead of 1st B ldw ZIlimit,#ZIbuf bra 11$ 10$: ldw A0,#ZIbuf ; load work pointers ldw ZIlimit,#ZIbuf-1 11$: inw ZIlimit jsr GetSByte stx LastError ldy #0 sta (A0),y cpx #0 ; EOF or other error beq 13$ rts 13$: inw A0 ; increment & move on cwi A0,#ZIflow ; filled input buffer? blt 11$ ldx #0 ; happy exit 14$: rts ror 12$: jmp Co2Unpack ; happy exit NotANY: .byte $18,"File is not in BEP format.",27,0 t2Nottab: .word t2Not41,t2Not71,t2Not81 .word t2NotCMD,t2NotCMD,t2NotCMD,t2NotCMD,8X0 UnLZW:  jsr ZdumpZ ; finish any old output  bne 11$ 10$: ldx #1 ; output buf full, exit! rts 11$: lda Oflow ; out of input flag set? beq 17$ ldx #0 ; out of input exit rts 17$: jsr LZZgc ; get a character jsr ZfillZ ; put data on ZUnBuf lda LZW1st bne 12$ ; handle empty table inc LZW1st ldb Tndx,#0 ; reason not to do ZfillZ bra 14$ 12$: ldx Tndx ; get table index inx cpx #$fe ; is it now full? bne 13$ ; yes, so add nothing ldb LZW1st,#0 ; clear 1st char again bra 14$ 13$: stx Tndx ; save, adjust table index dex lda W sta T0a,x lda W+1 ; add table entry sta T0b,x lda Zfst sta T0c,x 14$: mvw C,W ; make last entry jmp UnLZW ; continue (chks above!) .word t2NotCMD,t2NotCMD,t2NotCMD,t2NotCMD,8X0 LZZasl: .byte $0e ; asl ZIbyte: .word $ffff ; input buffer location php dec ZIbit ; remaining bits/this byte bne 10$ inw ZIbyte ; pull bits from next byte ldb ZIbit,#8 cpw ZIbyte,ZIlimit ; last effective byte bne 10$ ldb Oflow,#1 ; set overflow flag 10$: plp rts LZZgc: ldb C,#0 ; shift off coded char jsr LZZasl rol C ; get table flag bit ldy #8 10$: jsr LZZasl ; now get code/char rol C+1 ylp 10$ rts $ ; yes, so add nothing ldb LZW1st,#0 ; clear 1st c8X0 LZZputC: .byte $8d ; sta ZObyte: .word $ffff ; yup inw ZObyte cwi ZObyte,#$7800 ; Znuff iz written rts CMDSet: lda $8908 ; will be last availbale track clc adc #1 ; and add one 10$: rts rts last effective byte bne 108X0 ZdumpZ: ldy ZUnBuf ; restore index bne 10$ ; empty, so exit ldx #1 ; NE = OK, EQ = FULL rts 10$: lda ZUnBuf,y ; get letter from end jsr LZZputC ; output letter php ; save fullness flags dey beq 11$ plp ; no more to do, exit! bne 10$ ; continue if possible php 11$: sty ZUnBuf ; save new index plp rts ZfillZ: ldy #0 ; clear index to ZUnBuf lda C ; is thing a code? bne 10$ lda C+1 ; no, so push char bra 12$ 10$: ldx C+1 ; check for kwkwk case cpx Tndx bn8X0 ZfillZ: ldy #0 ; clear index to ZUnBuf lda C ; is thing a code? bne 10$ lda C+1 ; no, so push char bra 12$ 10$: ldx C+1 ; check for kwkwk case cpx Tndx bne 13$ lda W+1 ; yes, so fetch last thing ldx W ; was last thing a code? bne 11$ iny ; no, so push char 2nd sta ZUnBuf+2 bra 12$ 11$: tax ; set up the code iny ; protect 1st (last) place jsr Zfill2 ; decode the rest dey ; no need to do this now 12$: iny ; make room for 1st char sty ZUnBuf sta ZUnBuf+1 ; no, a letter, so exit sta Zfst rts 13$: Zfill2: lda T0c,x ; pull letter of code iny sta ZUnBuf,y lda T0a,x ; is this code a code? bne 10$ lda T0b,x ; no, so save and exit iny sty ZUnBuf ; save first char, exit sta ZUnBuf,y sta Zfst rts 10$: lda T0b,x ; yes, so fetch next... tax jmp Zfill2 a ZUnBuf+1 ; no, a letter, so exit sta Zfst rts 13$: Zfill2: lda T0c,x ; pull letter of code iny sta ZUnBuf,y lda T0a,x ; is this code a code? bne 10$ lda T0b,x ; no, so save and exit iny sty8X0 @;**************************************************** Go2Pack: lda SrcDrv jsr SecIOinit cpx #0 beq 10$ jmp DiskError 10$: ldw A4,#FileName  lda #12 8X0 jsr GetFilename  bne 11$ 8X099$ rts 11$: lda FileName beq 99$ 12$: jsr ChkOkPack bne 99$ jsr FixFNam lda DstDrv jsr SetDevice jsr OpenDisk ldw A2,#FileName ldb A3L,#$02 jsr CreatSF cpx #0 beq 13$ jmp DiskError 13$: jmp DoPakBEP uf sta ZUnBuf+8X0 ; ** check to see if the source drive can be packed ChkOkPack: lda SrcDrv jsr DriveST sta DrvType cmp #1 ; 1541 drive beq 10$ cmp #2 ; 1571 drive bne 16$ lda SrcDrv jsr SetDevice ldw R4,#$6000 ldb R1L,#40 ldb R1H,#0 jsr GetBlock cpx #0 beq 11$ ldb DrvType,#1 bra 10$ 16$: cmp #3 ; 1581 drive beq 12$ ldw A4,#660 ; "cmd" drive jsr CMDSet sta DrvMax ldb DrvType,#'C' bra 13$ 10$: ldw A4,#500 ; .D64 ldb DrvType,#36 bra 13$ 11$: ldw A4,#1000 ; .D71 ldb DrvType,#71 bra 13$ 12$: ldw A4,#2500 ; .D81 ldb DrvType,#81 13$: lda DstDrv jsr SetDevice jsr GetDirHead ldw R5,#$8200 jsr CalcBlksFree cpw R4,A4 blt 15$ ldx #0 99$: rts 15$: jsr i_CNCLBox .word t2NoBlks ldx #1 rts t2NoBlks: .byte $18,"Not enough space on dest.",27,0 rts t2NoBlks: .byte $18,"Not enough space on dest.",27,0 rts t2NoBlks: .byte $18,"Not enough space on dest.",27,0 nd re-store them cmp Temp ; same as actual? beq 99$ ; yes, so happy exit jsr i_YNBox ; no, so ask them nice8X0 FixFNam: ldw A0,#FileName 10$: ldy #0 lda (A0),y beq 16$ cmp #'.' bne 15$ inw A0 lda (A0),y beq 16$ cmp #'B' beq 11$ cmp #'b' bne 15$ 11$: rts 15$: inw A0 bra 10$ rts 16$: ldw A4,#t2fnExt ; needs extension 17$: lda (A4),y ; copy extension sta (A0),y beq 11$ iny bne 17$ rts t2fnExt: .byte ".BEP",0 xtension 17$: lda (A4),y ; copy extension sta (A0),y beq 11$ iny bne 17$ t2fnExt: .byte ".BEP",0 byte 11 .byte $12,$19 .word t2fnBtx1 .byte 13 .byte $28X0 DoPakBEP: ldb TRACK,#1 ldb SECTOR,#0 mvw TRACK,TNSTRACK jsr TnSBar lda #0 ; this is cool sta Oflow ; initialize overflow flag sta Tndx ; initialize table index sta LZW1st ; first LZW byte flag sta T0chk ; init table speed-checker ldb WObit,#8 ; set up output bit ptr ldw WObyte,#WObuf ; set out output buffer ptr mvw WObyte,A2 ; for temporary writing ldy #0 lda DrvType ; expected tracks sta (A2),y ; usually drive type inw WObyte cbi DrvType,#'C' bne 16$ lda DrvMax iny sta (A2),y inw WObyte 16$: jsr BPkTracks ; pack these tracks beq 21$ 20$: jmp DiskError 21$: jsr LZWpw ; push final W 22$: cbi WObit,#8 beq 23$ ; now fill final byte clc jsr LZWrol ; roll zeroes on board bra 22$ 23$: jsr BEPBufW ; dump rest of buffer bne 20$ ldb A2L,#130 jsr ClosSF jsr Imprint jsr i_OKBox .word t2Done  jmp HappyEnd owDst e jsr NewDst jmp ShowDst Dst Dst ot41: .byte $18,"Dest. Drive must be a 1541/1571.",27,0 t2Not71: .byte $18,"Dest. Drive must be a 1578X0 BPkTracks: 10$: ldw A2,#$6000 ldw A3,#$77ff jsr ReadSecs stx LastError ldw WIbyte,#$5fff mvw A2,WIlimit  mvw TRACK,TNSTRACK  jsr TnSBar ; NOW BEGIN WRITE PROCESS 8X012$: jsr LZW ; pack/load mid-buffer beq 13$ ; buffer full? no=dump jsr BEPBufW ; dump the buffer bne 15$ ; destination error beq 12$ ; finish LZW work 13$: ldx LastError beq 10$ cpx #2 beq 14$ cpx #$ff bne 15$ 14$: ldx #0 15$: rts yte cbi DrvType,#'C' bne 16$ ld8X0 LZW : lda LZW1st ; handle 1st char case  bne 10$ inc LZW1st ; first byte is special ldb W,#0 ldw WIbyte,#$6000 ; push out 1st byte mvb $6000,W+1 10$: lda Oflow ; is output buffer full? beq 11$ lda #1 ; full buffer exit rts 11$: inw WIbyte cpw WIbyte,WIlimit ; finished the T&S's? blt 12$ lda #0 ; need more sectors exit rts 12$: jsr LZWgetC ; get a char ldx T0chk 14$: cpx Tndx ; checked whole table beq 17$ lda W cmp T0a,x ; check W bne 16$ lda W+1 cmp T0b,x ; check W+1 bne 16$ lda C cmp T0c,x ; check char C bne 16$ stx W+1 ; found! set up new W ldb W,#128 inx stx T0chk bra 11$ ; continue looping 16$: inx ; check rest of table bne 14$ 17$: jsr LZWpw ; put W on out buf ldx Tndx inx cpx #$ff ; is table full? bne 18$ ldb Tndx,#0 bra 19$ 18$: stx Tndx ; now add to table dex lda W sta T0a,x ; add W+C to table lda W+1 sta T0b,x lda C sta T0c,x 19$: mvb C,W+1 ; make C new W ldb W,#0 sta T0chk jmp LZW ; do it all again! ke C n8X0 BEPBufW: mvw WObyte,A3 ; up to, not over WOflow dew A3 ; test ********** ldw A2,#WObuf ; start from top ldw WObyte,#WObuf 10$: lda DstDrv jsr SetDevice jsr PutSMem cpx #0 ; any dest error at all? bne 12$ lda Oflow beq 11$ ; was buffer full before? mvb WOflow,WObuf ; yes, so reset buffer ldb Oflow,#0 11$: ldx #0 12$: rts rts rts jsr LZWgetC ; get a char ldx T0chk 14$: cpx Tndx ; checked whole table beq 17$ lda W cmp T0a,x ; check W bne 16$ lda W+1 cmp T08X0 LZWgetC: .byte $ad ; lda WIbyte: .word $ffff ; T&S buffer location sta C ; get a character rts LZWrol: .byte $2e ; rol WObyte: .word $ffff ; output buffer location dec WObit bne 10$ avw #1,WObyte ; set up next byte ldb WObit,#8 cwi WObyte,#WOflow ; fill the buffer? bne 10$ ldb Oflow,#1 ; yes, so set flag 10$: rts LZWpw: lda W ; add to table routine asl a jsr LZWrol ; add table flag lda W+1 sta WOflow+9 ldy #8 10$: asl WOflow+9 ; now add code/char jsr LZWrol ylp 10$ rts 8X0 Go2Unpack: jsr i_CNCLBox .word t2NY2 rts t2NY2: .byte $18,"BEAP Unpack unimplemented.",27,0 rts LZWrol: .byte $2e ; rol WObyte: .word $ffff ; output buffer location dec WObit bne 10$ avw #1,WObyte ; 8X0 .ramsect File: .block 2 DrvType: .block 1 DrvMax: .block 1 LastError: .block 1 ProgOffset: .block 1 LastTnS: .block 2 LastMem: .block 2 byte Tndx: .block 1 ; pointer to last used table entry T0a: .block 256 ; 0 = normal 8X0 W: .block 2 ; official LZW "W" C: .block 2 ; character to check Zfst: .block 2 ; first letter of last output Tndx: .block 1 ; pointer to last used table entry T0a: .block 256 ; 0 = normal char, 1 = tabled T0b: .block 256 ; table index T0c: .block 256 ; table characters T0chk: .block 1 ; to keep from re-checking table WIlimit: .block 2 ; end of T&S buffer for reading ZIlimit: .block 2 ; end of read buffer WObit: .block 1 ; bit pos in out buf 4 LZW out ZIbit: .block 1 ; bit pos in input buf 4 LZW in Oflow: .block 1 ; overflow flag for WObuf, ZIbuf LZW1st: .block 1 ; to handle special 1st char case ZIbuf: WObuf: .block 10*256 ZIflow: WOflow: .block 10 ; overflow byte(s) for WObuf Temp: .block 18 ; whatever its needed for ZUnBuf: .block 256 ; unpacking buffer for an unLZW in TheEnd: .block 1 ; serves no purposeeEnd: .block 1 ; serves no purpose table lda W+1 sta T0b,x lda C sta T0c,x 19$: mvb C,W+1 ; make C new W ldb W,#0 sta T0chk jmp LZW ; do it all again! cess nS/6gbZIP4HPRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&zvLy&Z=<D*IBoo:BH8X ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .if Pass1 8X .noeqin .noglbl  .include GEOSequates .eqin .glbl .endif  .psect jmp Go2Z4 ; VPRGbase + 0 0 0 + 0 jmp AbtBox ; VPRGbase + 3 s.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod8X0 Go2Z4: cpb SrcDrv,DstDrv bne 10$ jsr i_CNCLBox .word t2txt0 rts 10$: lda PackUnpack beq 11$ jmp Go2Unpack 11$: jmp Go2Pack t2txt0: .byte "Source and Dest. must be different!",27,0 8X0 @;**************************************************** Go2Unpack:  lda DstDrv @  jsr SecIOinit cpx #0 bne 10$ lda DstDrv jsr DriveST cmp #2 ble 11$ jsr i_OKBox .word t2No41 jmp HappyEnd 10$: jmp DiskError 11$: lda SrcDrv jsr SetDevice jsr GetFirstFile ; get a filename cpx #$00 bne 12$ jmp StartUnZ4 12$: jsr i_CNCLBox .word t2NoFile  jmp HappyEnd  Co2Unpack: lda SrcDrv 8X0 jsr SetDevice jsr GetNxtFile cpx #$00 bne 10$ jmp StartUnZ4 10$: jsr i_OKBox .word t2Done jmp HappyEnd t2No41: .byte $18,"Dest. drive not a 1541/1571.",27,0 bne 19$ 40$: ldw RepRun,#0 ; non-repeat, so add normal lda (A0),y jsr PutBByte bne 19$ iny cpy #255 beq 60$ bne 10$ 50$: inc RepRu8X0 StartUnZ4: mvw A0,File mvw A0,FnamPtr jsr UnFixFile beq 10$ jsr NewSrc jmp HappyEnd 10$: ldw A2,#t2Ready jsr  DoNxtD ; confirm the whole process now 8X0 cbi sysDBData,#$03 beq 14$ ; ready to go! jmp HappyEnd 14$: nop ContUnZ4: lda SrcDrv jsr SetDevice jsr OpenDisk jsr FixFNam2 jsr FixTrkList bne 10$ jsr Imprint jmp Co2Unpack 10$: mvw FnamPtr,R6 ldb $886e,#$ff jsr FindFile cpx #0 ; did we find the file? beq 11$ jsr Imprint jsr i_OKCANBox ; confirm the next source .word t2NewSrc cbi sysDBData,#$01 beq 10$ ; ready to go! jmp HappyEnd 11$: ldy #$15 lda (R5),y ; is it sequential type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jmp HappyEnd 12$: mvw FnamPtr,A2 ldb A3L,#0 jsr OpenSF ; and open the file cpx #0 beq 13$ 16$: jmp DiskError 13$: jsr DoUnZ4 cpx #0 bne 15$ jmp ContUnZ4 15$: cpx #1 bne 17$ jsr Imprint jmp Co2Unpack 17$: jmp DiskError t2Done: .byte $18,"Operation Complete",27,0 t2NoFile: .byte $18,"Select a file to unpack.",27,0 t2BadFile: .byte $18,"File isn't 1st Zipcode image!",27,0 t2Ready: .byte $18,"Ready to unZipcode images?",27,0 t2NewSrc: .byte $18,"Insert next volume disk.",27,0 t2Ready: .byte $18,"Ready to unpack .BEP image?",8X0 UnFixFile: mvw FnamPtr,A2 ldw A3,#FileName+2 ldy #0 10$: lda (A2),y sta (A3),y beq 11$ iny bne 10$ 11$: lda FileName+3 cmp #'!' bne 14$ 13$: lda FileName+2 cmp #'1' beq 15$ 14$: jsr i_CNCLBox .word t2BadFile ldx #$ff rts 15$: ldb FileName+2,#'0' ldw FnamPtr,#FileName+2 ldx #0 rts FixTrkList: mvw FnamPtr,A0 ldy #0 lda (FnamPtr),y cmp #'1' bne 10$ ldb StartTrk,#1 ldb LastTrk,#8 rts 10$: cmp #'2' bne 12$ ldb StartTrk,#9 ldb LastTrk,#16 rts 11$: cmp8X0 FixTrkList: mvw FnamPtr,A0 ldy #0 lda (A0),y cmp #'1' bne 10$ ldb StartTrk,#1 ldb LastTrk,#8 ldx #1 rts 10$: cmp #'2' bne 11$ ldb StartTrk,#9 ldb LastTrk,#16 ldx #1 rts 11$: cmp #'3' bne 12$ ldb StartTrk,#17 ldb LastTrk,#25 ldx #1 rts 12$: cmp #'4' bne 13$ ldb StartTrk,#26 ldb LastTrk,#35 ldx #1 rts 13$: ldx #0 rts SetMaxSecs: ldb MaxSecs,#20 ldw LastMem,#$74ff cbi TRACK,#17 ble 10$ ldb MaxSecs,#18 ldw LastMem,#$72ff cbi TRACK,#24 ble 10$ 8X0 SetMaxSecs: ldb MaxSecs,#20 ldw LastMem,#$74ff ldw OrdPtr,#OrdBuf1 cbi TRACK,#17 ble 10$ ldb MaxSecs,#18 ldw LastMem,#$72ff  ldw OrdPtr,#OrdBuf2  cbi TRACK,#24 8X0 ble 10$ ldb maxSecs,#17 ldw LastMem,#$71ff  ldw OrdPtr,#OrdBuf3  cbi TRACK,#30 8X0 ble 10$ ldb MaxSecs,#16 ldw LastMem,#$70ff 10$: ldy #30 lda #0 sta SecList 11$: sta SecList,y ylp 11$ rts OrdBuf1: .byte 0,11,1,12,2,13,3,14,4,15,5,16,6,17,7,18,8,19,9,20,10 OrdBuf2: .byte 0,10,1,11,2,12,3,13,4,14,5,15,6,16,7,17,8,18,9 OrdBuf3: .byte 0,9,1,10,2,11,3,12,4,13,5,14,6,15,7,16,8,17 ial type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jsr NewSrc jmp ShowSrc 12$: mvw FnamPtr,A2 8X0 Get1stBytes: mvw FnamPtr,A0 ldy #0 lda (A0),y cmp #'1' bne 20$ ldb Repeats,#4 10$: jsr GetBByte cpx #0 bne 99$ dec Repeats bne 10$ ldx #0 99$: rts 20$: ldb Repeats,#2 bra 10$ ble 10$ ldb MaxSecs,#16 ldw LastMem8X0 GetBByte: cwi Z4LastB,#Z4buf bne 20$ 10$: ldw A2,#Z4buf ldw A3,#Z4bufE-1 ldw Z4ThisB,#Z4buf jsr GetSMem mvw A2,Z4LastB cpx #0 beq 20$ cpx #11 beq 20$ rts 20$: cpw Z4ThisB,Z4LastB bgt 10$ mvw Z4ThisB,A2 ldy #0 lda (A2),y inw Z4ThisB ldx #0 rts rts rts ldb LastTrk,#35 rts 13$: ldx #0 rts SetMaxSecs: ldb MaxSecs,#20 ldw LastMem,#$74ff cbi StartTrk,#17 ble 10$ ldb MaxSecs,#18 ldw LastMem,#$72ff cbi StartTrk,#24 ble 10$ ldb maxSecs,#17 ldw LastMe8X0 DoUnZ4: ldw Z4LastB,#Z4buf ldw Z4ThisB,#Z4buf jsr Get1stBytes beq 10$ rts 10$: mvb StartTrk,TRACK DoUnZ42: ldb SECTOR,#0  mvw TRACK,TNSTRACK  jsr TnSBar 8X0 jsr SetMaxSecs ldb SecLp,#0 10$: jsr UnZ4 cpx #0 beq 11$ rts 11$: inc SecLp cpb SecLp,MaxSecs ble 10$ ldw A2,#$6000 mvw LastMem,A3 mvw TRACK,LastTnS ldb SECTOR,#0 jsr WriteSecs mvw LastTnS,TRACK cpx #0 beq 12$ cpx #$ff beq 12$ rts ; error exit 12$: inc TRACK cpb TRACK,LastTrk bgt 13$ jmp DoUnZ42 13$: cbi LastTrk,#34 bgt 14$ ldx #0 ; done with group exit rts 14$: ldx #1 ; done altogether exit rts 17 ial type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jsr NewSrc jmp ShowSrc 12$: mvw FnamPtr,A2 8X0 UnZ4: jsr GetBByte cpx #0 beq 10$ rts 10$: sta CheckTrk jsr GetBByte cpx #0 beq 11$ rts 11$: sta SECTOR cpb SECTOR,MaxSecs ble 13$ 12$: ldx #2 rts 13$: lda CheckTrk and #63 cmp TRACK bne 12$ ldy SECTOR lda SecList,y bne 12$ lda #1 sta SecList,y lda CheckTrk and #128 cmp #128 bne 14$ jmp UnZ4128 14$: lda CheckTrk and #64 cmp #64 bne 15$ jmp UnZ464 15$: ldb Repeats,#0  ldw A0,#$6000 adb SECTOR,A0H  16$: jsr GetBByte 8X0 cpx #0 beq 17$ rts 17$: ldy Repeats sta (A0),y inc Repeats bne 16$ ldx #0 rts bge 20$ inc FileName+2 rts 20$: ldb FileName+2,#'0' cwi FnamPtr,#(FileName+2) blt 21$ ldw FnamPtr,#(FileName+1) 21$: lda FileName+1 cmp #'9' bge 22$ inc F8X0 UnZ4128: jsr GetBByte cpx #0 beq 10$ rts 10$: sta Repeats jsr GetBByte cpx #0 beq 11$ rts 11$: sta Z4byte ldb Z4code,#0 ldw A0,#$6000 adb SECTOR,A0H 12$: jsr GetBByte cpx #0 beq 13$ rts 13$: cmp Z4byte beq 14$ ldy Z4code sta (A0),y inc Z4code bra 20$ 14$: jsr GetBByte cpx #0 beq 15$ rts 15$: sta Repeats+1 jsr GetBByte cpx #0 beq 17$ 16$: rts 17$: dec Repeats beq 16$ dec Repeats 18$: ldy Z4code sta (A0),y inc Z4code dec Repeats+1 bne 18$ 20$: lda Repeats beq 21$ dec Repeats bne 12$ 21$: ldx #0 rts epeats bne 16$ ldx #0 rts bge 20$ inc FileName+2 rts 20$: ldb FileName+2,#'0' cwi FnamPtr,#(FileName+2) blt 21$ ldw FnamPtr,#(FileName+1) 21$: lda FileName+1 cmp #'9' bge 22$ inc F8X0 UnZ464: ldw A0,#$6000 adb SECTOR,A0H jsr GetBByte cpx #0 beq 10$ rts 10$: ldy #$00 11$: sta (A0),y ylp 11$ ldx #0 rts 0 ldw A0,#$6000 adb SECTOR,A0H 12$: jsr GetBByte cpx #0 beq 13$ rts 13$: cmp Z4byte beq 14$8X0 @;**************************************************** Go2Pack: lda SrcDrv jsr SecIOinit cpx #0 beq 10$ jmp DiskError 10$: ldw A4,#FileName+4 lda #14 jsr GetFilename bne 11$ 99$ rts 11$: lda FileName+4 beq 99$ 12$: jsr ChkOkPack bne 99$ jsr FixFNam 13$: jmp DoPakiZ4 ixFNam 13$: jmp DoPakiZ4 4 ixFNam 13$: jmp DoPakiZ4 4 4 0 beq 17$ 16$: rts 17$: dec Repeats beq 16$ dec Repeats 18$: ldy Z4code sta (A0),y inc Z4code dec Repeats+1 bne 18$ 20$: l8X0 DoPakiZ4: 10$: lda DstDrv jsr SetDevice jsr OpenDisk mvw FnamPtr,A2 ldb A3L,#$02 jsr CreatSF cpx #0 beq 13$ jmp DiskError 13$: jsr DoPakZ4 cpx #0 ; error exit? beq 15$ cpx #1 beq 16$ jmp DiskError 15$: ldb A2L,#130 jsr ClosSF cpx #0 bne 99$ jsr NxtFile beq 10$ cpx #$ff bne 99$ rts 16$: ldb A2L,#130 jsr ClosSF jsr Imprint jsr i_OKBox .word t2Done  jmp HappyEnd  99$: jmp DiskError or 4code sta (A0),y inc Z4code dec Repeats+1 bne 18$ 20$: l8X0 ; ** check to see if the source drive can be packed ChkOkPack: lda SrcDrv jsr SetDevice jsr OpenDisk lda SrcDrv jsr DriveST cmp #2 ble 10$ jsr i_CNCLBox .word t2No1571 ldx #1 rts 10$: jsr GetDirHead ldy #162 lda $8200,y sta DiskID lda $8201,y sta DiskID+1 lda DstDrv jsr SetDevice jsr GetDirHead ldw R5,#$8200 jsr CalcBlksFree cwi R4,#200 blt 15$ ldx #0 99$: rts 15$: jsr i_CNCLBox .word t2NoBlks ldx #1 rts t2NoBlks: .byte $18,"Not enough space on dest.",27,0 t2No1571: .byte $18,"Source is not a 1541/1571.",27,0 bne 16$ ldx #0 rts exit rts 14$: ldx #1 ; done altogether exit rts 17 ial type? beq 12$ jsr i_CNCLBox ; no, so exit .word t2BadFile jsr NewSrc jmp ShowSrc 12$: mvw FnamPtr,A2 8X0 NxtFile: jsr FixFNam2 lda DstDrv jsr SetDevice jsr GetDirHead ldw R5,#$8200 jsr CalcBlksFree cwi R4,#200 blt 15$ ldx #0 99$: rts 15$: jsr Imprint jsr i_OKCANBox .word t2NxtDsk cbi sysDBData,#$01 beq 16$ ldx #$ff rts 16$: jsr OpenDisk cpx #0 rts iskID+1 lda DstDrv jsr SetDevice jsr GetDirHead ldw R5,#$8200 jsr CalcBlksFree cwi R4,#200 blt 15$ ldx #0 99$: rts 15$: jsr i_CNCLBox .word t2NoBlks ldx #1 rts t2NoBlks: .byte $18,"Not enough space on8X0 FixFNam2: lda FileName+2 cmp #'9' bge 20$ inc FileName+2 rts 20$: ldb FileName+2,#'0' cwi FnamPtr,#(FileName+2) blt 21$ ldw FnamPtr,#(FileName+1) 21$: lda FileName+1 cmp #'9' bge 22$ inc FileName+1 rts 22$: ldb FileName+1,#'0' cwi FnamPtr,#(FileName+1) blt 23$ ldw FnamPtr,#FileName 23$: inc FileName rts t2NxtDsk: .byte $18,"Destination full. Insert next.",27,0 2NoBlks: .byte $18,"Not enough space on dest.",27,0 t2No1571: .byte $18,"Source is not a 1541/1578X0 FixFNam: ldw A4,#t2fnPre ldw A0,#FileName ldy #0 19$: lda (A4),y beq 20$ sta (A0),y iny bne 19$ 20$: ldw FnamPtr,#FileName+2 rts t2fnPre: .byte "001!",0 : lda (A4),y beq 20$ sta (A0),y iny bne 19$ 20$: ldw FnamPt8X0 DoPakZ4: ldw Z4ThisB,#Z4buf ; prepare write buf jsr FixTrkList ; set start/end track mvb StartTrk,TRACK jsr Put1stBytes beq 10$ rts 10$: DoZ4loop: ldb SecLp,#0 ldb SECTOR,#0 ; for display sake  mvw TRACK,TNSTRACK  jsr TnSBar 8X0 jsr SetMaxSecs mvw TRACK,LastTnS ldb SECTOR,#0 ldw A2,#$6000 ldw A3,#$60ff adb MaxSecs,A3H jsr ReadSecs mvw LastTnS,TRACK cpx #$ff beq 10$ cpx #0 beq 10$ rts 10$: mvw OrdPtr,A2 ; get ordptr ldy SecLp lda (A2),y sta SECTOR jsr DoZ4 ; now zip this sector cpx #0 beq 11$ rts 11$: inc SecLp cpb SecLp,MaxSecs ble 10$ inc TRACK cpb TRACK,LastTrk bgt 13$ jmp DoZ4loop 13$: jsr PutBFlush cpx #0 beq 14$ rts 14$: cbi LastTrk,#34 bgt 15$ ldx #0 ; done with group exit rts 15$: ldx #1 ; done altogether exit rts skError 13$: jsr DoUnZ4 cpx #0 bne 15$ jmp ContUnZ4 15$: cpx #1 bne 17$ jsr Imprint jmp Co2Unpack 17$: jmp DiskError t2Done: .byte $18,"Operation Complete",27,0 t2NoFile: .byte8X0 DoZ4: jsr ZScan cmp #0 bne 20$ lda TRACK jsr PutBByte cpx #0 beq 12$ 11$: rts 12$: lda SECTOR jsr PutBByte cpx #0 bne 11$ ldb Repeats,#0 15$: ldw A0,#$6000 ; get source buf ptr adb SECTOR,A0H ldy Repeats lda (A0),y jsr PutBByte cpx #0 bne 11$ inc Repeats bne 15$ ldx #0 19$: rts 20$: cmp #$ff bne 30$ lda TRACK ora #64 jsr PutBByte bne 19$ lda SECTOR jsr PutBByte bne 19$ ldw A0,#$6000 ; get source buf ptr adb SECTOR,A0H lda (A0),y jsr PutBByte rts 30$: lda TRACK ora #$80 jsr PutBByte bne 19$ lda SECTOR jsr PutBByte bne 19$ lda RepBSize jsr PutBByte bne 19$  lda RepChar jsr PutBByte bne 19$  jmp DoZ4Tuff 8X0 e bne 19$ iny cpy #255 beq 60$ bne 10$8X0 DoZ4Tuff: ldw A0,#$6000 ; get source buf ptr adb SECTOR,A0H mvw A0,A1 inw A1 ldy #0 ldw RepRun,#0 10$: lda (A0),y ; start scanning cmp (A1),y beq 50$ ; an equal case lda RepRun ; nonequal, so check end rep beq 40$ cmp #3 ; end rep, but enough? bge 30$ 15$: lda (A0),y ; no, so just put them out jsr PutBByte beq 20$ 19$: rts 20$: dec RepRun ; until RepRun is 0 again bne 15$ bra 40$ ; then skip to non-rep case 30$: lda RepChar ; rep, and enough, so out! jsr PutBByte ; fancy rep char bne 19$ inc RepRun ; it will be one short lda RepRun ; and number of reps! jsr PutBByte bne 19$ 40$: ldw RepRun,#0 ; non-repeat, so add normal lda (A0),y jsr PutBByte bne 19$ iny cpy #255 beq 60$ bne 10$ 50$: inc RepRun ; repeat, so note this iny cpy #255 bne 10$ 60$: jmp DoZ42 jmp DiskError 13$: jsr DoUnZ4 cpx #0 bne 15$ jmp ContUnZ4 15$: cpx #1 bne 17$ jsr Imprint jmp Co2Unpack 17$: jmp DiskError t2Done: .byte $18,"Operation Complete",27,0 t2NoFile: .byte8X0 DoZ42: lda RepRun ; clean up! were we repeating? bne 70$ lda (A0),y ; no, so the final byte jsr PutBByte 69$: rts 70$: cmp #3 ; did we repeat enough? bge 80$ 75$: lda (A0),y ; no, so just put them out jsr PutBByte bne 69$ dec RepRun bne 75$ bra 90$ ; then skip to last byte 80$: lda RepChar ; repped enough, so out! jsr PutBByte bne 69$ inc RepRun ; will be one short lda RepRun jsr PutBByte bne 69$ 90$: lda (A0),y ; and finally, the final byte jsr PutBByte bne 69$ ldx #0 rts har bne 19$ inc RepRun ; it will be one short lda RepRun ; and number of reps! jsr PutBByte bne 19$ 40$: ldw RepRun,#0 ; non-repeat, so add normal lda (A0),y jsr PutBByte bne 19$ iny cpy #255 beq 60$ bne 10$ 50$: inc RepRu8X0 ZScan: ldw RepSize,#2 ldb RepBSize,#0 ldw Repeats,#0 ldw A0,#$6000 ; get source buf ptr adb SECTOR,A0H mvw A0,A1 inw A1 ldy #0 ldw RepRun,#0 10$: lda (A0),y ; start scanning cmp (A1),y beq 20$ 12$: lda RepRun beq 15$ cmp #3 bge 13$ adw RepRun,RepSize adb RepRun,RepBSize bra 15$ 13$: inc Repeats ; a real repeat, so add repcode inw RepSize inw RepSize inw RepSize avb #2,RepBSize 15$: ldw RepRun,#0 ; non-repeat, so add normal inc RepBSize inw RepSize iny cpy #255 beq 30$ bne 10$ 20$: inc RepRun ; repeat, so note this iny cpy #255 bne 10$ 30$: jmp ZScan2 bne 10$ 30$: jmp ZScan2 n2 n2 non-repeat, so add normal lda (A0),y jsr PutBByte bne 19$ iny cpy #255 beq 60$ bne 10$ 50$: inc RepRu8X0 ZScan2: lda RepRun beq 35$ cmp #3 bge 33$ adw RepRun,RepSize adb RepRun,RepBSize bra 35$ 33$: inc Repeats ; a real repeat, so add repcode inw RepSize inw RepSize inw RepSize avb #2,RepBSize 35$: inc RepBSize lda Repeats bne 36$ rts ; return NO repeats, full block 36$: cbi RepRun,#255 blt 40$ rts 40$: cbi RepBSize,#253 ; check for savings blt 45$ lda #0 ; none, so just fill it rts 45$: ldy #0 tya 46$: sta RepBuf,y ylp 46$ 47$: lda (A0),y tax lda #1 sta RepBuf,x ylp 47$ 48$: lda RepBuf,y beq 50$ iny bne 48$ lda #1 rts 50$: tya sta RepChar lda #1 rts BByte bne 19$ 40$: ldw RepRun,#0 ; non-repeat, so add normal lda (A0),y jsr PutBByte bne 19$ iny cpy #255 beq 60$ bne 10$ 50$: inc RepRu8X0 Put1stBytes: cbi TRACK,#1 beq 12$ lda #$00 ; other tracks stuff jsr PutBByte bne 99$ lda #$04 jsr PutBByte 99$: rts 12$: lda #$fe ; first track stuff jsr PutBByte bne 99$ lda #$03 jsr PutBByte bne 99$ lda DiskID jsr PutBByte bne 99$ lda DiskID+1 jsr PutBByte rts sr PutBByte rts 0 jsr PutBByte rts rts rts 0 jsr PutBByte rts rts rts 0 jsr PutBByte rts rts rts 0 jsr PutBByte rts rts 0 jsr PutBByte rts rts rts 08X0 PutBByte: pha sty A9L cwi Z4ThisB,#Z4bufE blt 20$ 10$: jsr PutBFlush beq 20$ ldy A9L pla cpx #0 rts 20$: mvw Z4ThisB,A2 inw Z4ThisB pla ldy #0 sta (A2),y ldy A9L ldx #0 rts PutBFlush: ldw A2,#Z4buf mvw Z4ThisB,A3 ldw Z4ThisB,#Z4buf dew A3 jsr PutSMem cpx #0 rts 0 rts 255 blt 40$ rts 40$: cwi RepSize,#258 ; check for savings blt 45$ lda #0 ; none, so just fill it rts 45$: ldy #0 tya 46$: sta RepBuf,y ylp 46$ 47$: lda (A0),y tax lda #18X0 .ramsect File: .block 2 FnamPtr: .block 2 CheckTrk: .block 1 SecLp: .block 1 StartTrk: .block 1 LastTrk: .block 1 MaxSecs: .block 1 SecList: .block 50 DiskID: .block 2 OrdPtr: .block 2 LastError: .block 1 OtherLast: .block 1 ProgOffset: .block 1 LastBlk: .block 2 LastTnS: .block 2 LastMem: .block 2 Z4code: .block 1 Z4byte: .block 1 Repeats: .block 2 RepSize: .block 2 RepBSize: .block 1 RepChar: .block 1 RepBuf: .block 256 RepRun: .block 2 Z4Offset: .block 2 Z4LastB: .block 2 Z4ThisB: .block 2 Z4buf: .block 512 Z4buf2: .block 10*256 Z4bufE: rts 50$: tya sta RepChar lda #1 rts 2 bne 10$ 30$: jmp ZScan2 n2 n2 Math,#0 ; non-repeat, so add normal lda (A0),y jsr PutBByte bne 19$ iny cpy #255 beq 60$ bne 10$S/7gbCVTPRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&{`j)v8X ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .if Pass1 8X .noeqin .noglbl  .include GEOSequates .eqin .glbl .endif  .psect jmp Go2CVT ; VPRGbase + 0 0 + 0 jmp AbtBox ; VPRGbase + 3 s.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod8X0 Go2CVT: lda PackUnpack beq 11$ jmp Go2Unpack 11$: jmp Go2Pack lbl .endif  .psect jmp Go2CVT ; VPRGbase + 0 ȭ7qP)8qȭ9q e DPɠ P7698X0 @;**************************************************** Go2Unpack: ldw A2,#t2Ready1 @  cpb SrcDrv,DstDrv beq 10$ ldw A2,#t2Ready2 10$: jsr YNBox cbi sysDBData,#$03 bne 12$ @  lda SrcDrv jsr SetDevice jsr GetFirstFile ; get a filename cpx #$00 bne 11$ jmp StartUnCVT 11$: jsr i_CNCLBox .word t2NoFile 12$: jmp HappyEnd Co2Unpack: lda SrcDrv jsr SetDevice jsr GetNxtFile cpx #$00 bne 10$ jmp StartUnCVT ; A0 points 10$: jsr i_OKBox .word t2Done  jmp HappyEnd  t2Done: .byte $18,"Operation Complete",27,0 8X0t2NoFile: .byte $18,"Select one or more files.",27,0 t2Ready1: .byte $18,"Ready to unconvert file(s)?",27,0 t2Ready2: .byte $18,"Copy and unconvert file(s)?",27,0 t2Ready3: .byte $18,"Ready to convert file(s)?",27,0 t2Ready4: .byte $18,"Copy and convert file(s)?",27,0 and convert file(s)?",27,0 7,0 7,0 and convert file(s)?",27,0 7,0 7,0 $18,"Operation Complete",27,0 t2NoFile: .byte $18,"Select a file to unpack.",8X0 StartUnCVT: mvw A0,File lda SrcDrv jsr SetDevice jsr OpenDisk cpb SrcDrv,DstDrv beq 50$ ldw A2,#t2Copy mvw File,A3 jsr FileBar mvw File,A2 mvw File,A3 ldw A4,#$6000 ldw A5,#$7f00 mvb DstDrv,A6L jsr FileCopy cpx #0 beq 49$ 48$: jmp DiskError 49$: lda DstDrv jsr SetDevice jsr OpenDisk 50$: ldw A2,#t2UnConvert mvw File,A3 jsr FileBar mvw File,A2 jsr unConv cpx #0 bne 60$ jsr Imprint jmp Co2Unpack 60$: cpx #$ff bne 48$ mvw File,A2 ldb t2BadFile,#34 ldy #0 61$: lda (A2),y ; copy filename beq 62$ sta t2BadFile+1,y iny bne 61$ 62$: ldx #0 63$: lda t2BadMs1,x sta t2BadFile+1,y beq 64$ inx iny bne 63$ 64$: jsr Imprint ldw A2,t2BadFile jsr OKCANBox cbi sysDBData,#$01 beq 66$ ldx #0 jmp DiskError 66$: jsr Imprint jmp Co2Unpack t2BadFile: .block 100 t2BadMs1: .byte 34," is not CVT!",27,0 t2BadMs2: .byte 34," is not GEOS!",27,0 t2Copy: .byte 27,"Copying:",0 t2Convert: .byte 27,"Converting:",0 t2UnConvert: .byte 27,"Unconverting:",0 .b8X0 @;**************************************************** Go2Pack: ldw A2,#t2Ready3 @  cpb SrcDrv,DstDrv beq 10$ ldw A2,#t2Ready4 10$: jsr YNBox cbi sysDBData,#$03 bne 12$ @  lda SrcDrv jsr SetDevice jsr GetFirstFile ; get a filename cpx #$00 bne 11$ jmp StartCVT 11$: jsr i_CNCLBox .word t2NoFile 12$: jmp HappyEnd Co2Pack: lda SrcDrv jsr SetDevice jsr GetNxtFile cpx #$00 bne 10$ jmp StartCVT ; A0 points 10$: jsr i_OKBox .word t2Done  jmp HappyEnd owSrc jsr NewDst jmp ShowDst jsr NewDst jmp ShowDst st st bne 61$ 62$: ldx #0 63$: lda t2BadMs1,x sta t2BadFile+1,y beq 64$ inx iny bne 63$ 64$: jsr Imprint ldw A2,t2BadFile jsr OKCANBox cbi sysDBData,#$01 beq 66$ ldx #0 jmp D8X0 StartCVT: mvw A0,File lda SrcDrv jsr SetDevice jsr OpenDisk cpb SrcDrv,DstDrv beq 50$ ldw A2,#t2Copy mvw File,A3 jsr FileBar mvw File,A2 mvw File,A3 ldw A4,#$6000 ldw A5,#$7f00 mvb DstDrv,A6L jsr FileCopy cpx #0 beq 49$ 48$: jmp DiskError 49$: lda DstDrv jsr SetDevice jsr OpenDisk 50$: ldw A2,#t2Convert mvw File,A3 jsr FileBar mvw File,A2 jsr Convert cpx #0 bne 60$ jsr Imprint jmp Co2Pack 60$: cpx #$ff bne 48$ mvw File,A2 ldb t2BadFile,#34 ldy #0 61$: lda (A2),y ; copy filename beq 62$ sta t2BadFile+1,y iny bne 61$ 62$: ldx #0 63$: lda t2BadMs2,x sta t2BadFile+1,y beq 64$ inx iny bne 63$ 64$: jsr Imprint ldw A2,t2BadFile jsr OKCANBox cbi sysDBData,#$01 beq 66$ ldx #0 jmp DiskError 66$: jsr Imprint jmp Co2Pack rts t2BadFile: .block 100 t2BadMs1: .byte 34," is not CVT!",27,0 t2BadMs2: .byte 34," is not GEOS!",27,0 t2Copy: .byte 27,"Copying:",0 t2Convert: .byte 27,"Converting:",0 t2UnConvert: .byte 27,"Unconverting:",0 .b8X0 .ramsect TRACK: ; for fun SECTOR: ; for fun File: .block 2 ; the file being worked onewDst jmp ShowDst $6000 ldw A5,#$7800 mvb DstDrv,A6L jsr FileCopy cpx #0 beq 49$ 48$: jmp DiskError 49$: lda DS/8gbLNXUPRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&{`}wcMGi-.Y^ `+g8X ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .if Pass1 8X .noeqin .noglbl  .include GEOSequates .eqin .glbl .endif  .psect jmp Go2LNX ; VPRGbase + 0 0 + 0 jmp AbtBox ; VPRGbase + 3 s.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod8X0 Go2LNX: lda PackUnpack beq 11$ jmp Go2Unpack 11$: jmp Go2Pack lbl .endif  .psect jmp Go2LNX ; VPRGbase + 0 q 10$ ldw A2,#t2Ready4 10$: jsr YNBox cbi sysDBData,#$03 bne 12$ @  ldw A2,#t2Copy mvw File,A3 jsr8X0 @;**************************************************** Go2Unpack:  cpb SrcDrv,DstDrv bne 90$ jsr numPicked cpx #1 bgt 13$ 90$: jsr GetFirstFile ; get a filename cpx #$00 bne 11$ ldw A2,#t2Ready1 @  cpb SrcDrv,DstDrv beq 10$ ldw A2,#t2Ready2 10$: jsr YNBox cbi sysDBData,#$03 bne 12$ @  lda SrcDrv jsr SetDevice jmp StartUnLNX 11$: jsr i_CNCLBox .word t2NoDFile 12$: jmp HappyEnd 13$: jsr i_CNCLBox .word t2NoMulti bra 12$ Co2Unpack: @  cpb SrcDrv,DstDrv beq 10$ lda SrcDrv jsr SetDevice jsr GetNxtFile cpx #00 bne 10$ jmp StartUnLNX 10$: jsr i_OKBox .word t2Done  jmp HappyEnd  t2Done: .byte $18,"Operation Complete",27,0 8X0t2NoDFile: .byte $18,"Select a file to unpack.",27,0 t2NoMulti: .byte $18,"Select only one (1) file.",27,0 t2NoFile: .byte $18,"Select one or more files.",27,0 t2Ready1: .byte $18,"Ready to de-LYNX file?",27,0 t2Ready2: .byte $18,"Copy and de-LYNX file?",27,0 t2Ready3: .byte $18,"Ready to LYNX file(s)?",27,0 t2Ready4: .byte $18,"Copy and LYNX file(s)?",27,0 t2BadFile: .block 100 t2BadMs1: .byte 34," is not LYNXed!",27,0 t2Copy: .byte 27,"Copying:",0 t2Lynx: .byte 27,"LYNXing:",0 t2Clean: .byte 27,"Closing:",0 t2DeLynx: .byte 27,"De-LYNXing:",0 t2Convert: .byte 27,"Converting:",0 t2UnConvert: .byte 27,"Unconverting:",0 t2UnLink: .byte 27,"Re-Linking:",0 0 : .byte 27,"Re-Linking:",0 ",0 ",0 ",0 cmp #$02 ; have we seen three now? bne 59$ ; no, so keep going... lda Repeats ; two or8X0 StartUnLNX: mvw A0,File ldw FNTabE,#$6000 lda SrcDrv jsr SetDevice jsr OpenDisk cpb SrcDrv,DstDrv beq 50$ ldw A2,#t2Copy mvw File,A3 jsr FileBar mvw File,A2 mvw File,A3 ldw A4,#$6000 ldw A5,#$7f00 mvb DstDrv,A6L jsr FileCopy cpx #0 beq 50$ 48$: jmp DiskError 50$: lda DstDrv jsr SetDevice jsr OpenDisk mvw File,A2 ldb A3L,#$ff jsr OpenSF cpx #0 bne 48$ mvw $8401,HeadTNS jsr isLYNX beq 60$ 59$: jmp notLYNX 60$: jsr inNum bne 62$ mvw A2,NumFiles jsr findLHead bne 62$ 61$: jsr deLYNX beq 65$ cpx #$ff beq 59$ 62$: jmp DiskError 65$: jsr deLYNXfile bne 62$ dew NumFiles cwi NumFiles,#0 bne 61$ jsr doneDLYNX bne 62$ jsr Imprint jmp Co2Unpack r Imprint jmp Co2Unpack k k on Complete8X0 deLYNX: ldw A2,#FNBuf jsr inStr bne 24$ lda FNBuf beq 23$ ldw A2,#t2DeLynx ldw A3,#FNBuf jsr FileBar cwi ThisTNS,#0 beq 23$ jsr inNum bne 24$ cwi A2,#0 beq 23$ mvw A2,FileBlocks ldw A2,#SafeBuf jsr inStr bne 24$ ldy #0 20$: lda TypeTab,y cmp SafeBuf beq 25$ iny cpy #7 blt 20$ 23$: ldx #$ff 24$: rts 25$: jmp deLYNX2 #0 lda TypeTab2,y sta TypeInfo cmp #$84 bne 30$ jsr inNum bne 24$ cwi A2,#0 beq 23$ mvw A2,RelInfo 30$: jsr inNum bne 24$ mvw8X0 deLYNX2: ldw RelInfo,#0 lda TypeTab2,y sta TypeInfo cmp #$84 bne 30$ jsr inNum bne 24$ cwi A2,#0 beq 23$ mvw A2,RelInfo 30$: cbi NumFiles,#1 beq 33$ jsr inNum bne 24$ mvw A2,FileLSize cwi A2,#0 beq 23$ 33$: mvw FNTabE,A0 ldx #0 ldy #0 35$: lda FNBuf,x sta (A0),y beq 40$ inw A0 inx bne 35$ 40$: mvw A0,FNTabE inw FNTabE ldx #0 rts 23$: ldx #$ff 24$: rts ny sta $8000,y iny lda RelInfo sta $8000,y iny lda #0 sta $8000,y tya add #6 tay lda F8X0 deLYNXfile: ldb R10L,#0 jsr GetFreeDirBlk ; now find a directory entry cpx #0 beq 10$ ; a error getting dir entry! rts 10$: mvw R1,DirTNS sty DirPTR ldx #0 lda TypeInfo sta $8000,y iny lda ThisTNS sta $8000,y iny lda ThisTNS+1 sta $8000,y iny 20$: lda FNBuf,x beq 25$ sta $8000,y iny inx bne 20$ 25$: cpx #16 beq 30$ lda #$a0 sta $8000,y iny inx bne 25$ 30$: lda #0 sta $8000,y iny sta $8000,y iny lda RelInfo sta $8000,y iny lda #0 sta $8000,y tya add #6 tay lda FileBlocks sta $8000,y iny lda FileBlocks+1 sta $8000,y jmp unLINK NX tay pla sta $8000,y dey pla sta $8000,y 50$: mvw ThisTNS,R1 ldw R4,#$8100 jsr GetBlock cpx #0 bne 99$ mvw $8100,ThisTNS dew FileBlocks cwi 8X0 unLINK: lda TypeInfo and #$1f cmp #4 beq 50$ jmp unLINK2 50$: jsr CalcRelBlocks cpx #0 bne 24$  sbw RelBlocks,FileBlocks 8X021$: mvw ThisTNS,R1 ldw R4,#$8100 jsr GetBlock cpx #0 beq 25$ 24$: rts 25$: mvw $8100,ThisTNS dew RelBlocks cwi RelBlocks,#0 bne 21$ 30$: lda $8100 beq 40$ ldw $8100,#$ff00 jsr PutBlock cpx #0 bne 24$ 40$: ldy DirPTR iny lda ThisTNS sta $8000,y iny lda ThisTNS+1 sta $8000,y lda DirPTR add #$13 tay lda RelTNS sta $8000,y iny lda RelTNS+1 sta $8000,y jmp unLINK2 40$ ldw $8100,#$ff00 jsr PutBlock cpx #0 bne 24$ 40$: ldy DirPTR iny lda ThisTNS sta $8000,y iny lda ThisTNS+1 sta $8000,y lda DirPTR add #$13 tay lda RelTNS sta 8X0 unLINK2: 50$: mvw ThisTNS,R1 ldw R4,#$8100 jsr GetBlock cpx #0 bne 99$ mvw $8100,ThisTNS dew FileBlocks cwi FileBlocks,#0 bne 50$ 60$: lda $8100 beq 70$ ldb $8100,#0 mvb FileLSize,$8101 jsr PutBlock cpx #0 bne 99$ 70$: ldw R4,#$8000 mvw DirTNS,R1 jsr PutBlock cpx #0 99$: rts 9$: rts 9$: rts beq 25$ 24$: rts 25$: mvw $8100,ThisTNS dew RelBlocks cwi RelBlocks,#0 bne 21$ 30$: lda $8100 beq 40$ ldw $8100,#$ff00 jsr PutBlock cpx #0 bne 24$ 40$: ldy DirP8X0 CalcRelBlocks:  mvw FileBlocks,SafeBuf ; first calc relblocks ldw RelBlocks,#1 10$: cwi SafeBuf,#120 blt 20$ svw #120,SafeBuf inw RelBlocks bra 10$ 20$: mvw ThisTNS,RelTNS mvw ThisTNS,R1 ldw R4,#$8100 jsr GetBlock cpx #0 bne 24$ lda $8102 beq 25$ inw RelBlocks ; an "extra" for 1581-types 25$: ldx #0 24$: rts ts dew FileBlocks blt 15$ 30$: ldx #0 rts rts a DirPTR add #$13 tay lda RelTNS sta $8000,y iny lda RelTNS+1 sta $8000,y jmp unLINK2 vw8X0 doneDLYNX: mvw File,R0 jsr DeleteFile cpx #0 beq 10$ rts 10$: ldw FNTabP,#$6000 doneDAR2: ldw A2,#t2UnConvert mvw FNTabP,A3 jsr FileBar mvw FNTabP,A2 jsr unConv cpx #0 beq 20$ cpx #$ff bne 19$ mvw CONVdptr,R5 ldy #0 lda (R5),y and #$1f cmp #4 bne 20$ iny lda (R5),y sta FCOPbtns iny lda (R5),y sta FCOPbtns+1 ldy #$13 lda (R5),y sta FCOPitns iny lda (R5),y sta FCOPitns+1 ldw FCOPbufS,#$7d00 ldw A2,#t2UnLink mvw FNTabP,A3 jsr FileBar jsr GetDirHead jsr FCOPreLink jsr PutDirHead bra 20$ 19$: cpx #0 rts 20$: ldy #0 inw FNTabP cpw FNTabP,FNTabE bge 30$ mvw FNTabP,A0 ldy #0 lda (A0),y bne 20$ inw FNTabP cpw FNTabP,FNTabE bge 30$ jmp doneDAR2 30$: ldx #0 rts ldx #0 rts rts8X0 findLHead: mvw HeadTNS,ThisTNS mvw HeadSize,A0 10$: mvw ThisTNS,R1 ldw R4,#$8100 jsr GetBlock cpx #0 bne 99$ dec A0L bne 11$  mvw $8100,ThisTNS  ldw $8100,#$ff00 8X0 jsr PutBlock cpx #0 99$: rts 11$: mvw $8100,ThisTNS bra 10$ bge 30$ mvw FNTabP,A0 ldy #0 lda (A0),y bne 20$ inw FNTabP cpw FNTabP,FNTabE blt 15$ 30$: ldx #0 rts y iny sta $8000,y iny lda RelInfo sta $8000,y iny lda #0 sta $8000,y tya add #6 tay lda F8X0 isLYNX: jsr GetSByte ; check for old LYNX cpx #0 bne 12$ cmp #$20 ; first space is OLD LYNX beq 20$ 10$: ldb A0L,#3 ; number of 0s 11$: jsr GetSByte cpx #0 beq 13$ 12$: rts 13$: cmp #0 bne 10$ dec A0L ; only 3 will do... bne 11$ 20$: ldb A0L,#0 ; index into ChrBuf 21$: jsr GetSByte cpx #0 bne 12$ cmp #$0d beq 21$ cmp #$20 ; now get up to sig beq 21$ ; which is number cmp #'0' ; of directory blocks blt 30$ cmp #'9' bgt 30$ ldy A0L sta ChrBuf,y inc A0L bra 21$ 30$: pha ldy A0L lda #0 sta ChrBuf,y ; get # dir blks from sig jsr ChrToDec mvw A2,HeadSize ldw A2,#FNTab ldb A0L,#0 ldb A0H,#$ff pla bra 35$ 31$: jsr GetSByte ; inspect the header cpx #0 beq 33$ 32$: rts 33$: cmp #$0d ; reading a byte at a time bne 35$ ldx A0H ; A0H has return code rts 35$: ldy A0L cmp t2isLYNX,y ; look for the word "LYNX" bne 37$ inc A0L cpb A0L,#4 blt 31$ ldb A0H,#0 ; kaplah! 37$: ldb A0L,#0 beq 31$ ; now clear all the way to end of signiture t2isLYNX: .byte "LYNX" 2Ready3: .byte $18,"Ready to LYNX file(s)?",27,0 t2Ready4: .byte $18,"Copy and LYNX file(s)?",27,0 t2BadFile: .block 100 t2BadMs1: .byte 34," is not LYNXed!",27,0 t2Copy: .byte 27,"Copying:",0 t2Lynx: .byte 27,"LYNXing:",0 t2Clean: .byte 8X0 notLYNX: mvw File,A2 ldb t2BadFile,#34 ldy #0 61$: lda (A2),y ; copy filename beq 62$ sta t2BadFile+1,y iny bne 61$ 62$: ldx #0 63$: lda t2BadMs1,x sta t2BadFile+1,y beq 64$ inx iny bne 63$ 64$: jsr Imprint ldw A2,t2BadFile jsr CNCLBox  jmp HappyEnd owSrc jsr NewDst jmp ShowDst jsr NewDst jmp ShowDst st st 20 ; now get up to sig beq 21$ ; which is number cmp #'0' ; of directory blocks blt 30$ cmp #'9' bgt 30$ ldy A0L sta ChrBuf,y inc A0L 8X0 inStr: ldb A0L,#0 10$: jsr GetSByte cpx #0 beq 11$ rts 11$: cmp #$0d beq 20$ ldy A0L sta (A2),y inc A0L bne 10$ 20$: ldy A0L lda #0 sta (A2),y tax rts : ldy A0L lda #0 sta ChrBuf,y jsr ChrToDec ldx #0 rts 8X0 inNum: ldb A0L,#0 10$: jsr GetSByte cpx #0 beq 11$ rts 11$: cmp #$0d beq 20$ cmp #'0' blt 10$ cmp #'9' bgt 10$ ldy A0L sta ChrBuf,y inc A0L bne 10$ 20$: ldy A0L lda #0 sta ChrBuf,y jsr ChrToDec ldx #0 rts 8X0 numPicked : ldx #0 ldy #$00 10$: lda  SrcPicks ,y 8X0 beq 11$ inx 11$: dey bne 10$ rts 0L sta ChrBuf,y inc A0L bne 10$ 20$: ldy A0L lda #0 sta ChrBuf,y jsr ChrToDec ldx #0 rts 8X0 @;**************************************************** Go2Pack: ldw A4,#FileName lda #12 jsr GetFilename beq 12$ lda FileName beq 12$ jsr FixFNam ldw NumFiles,#0 ldw FNTabE,#FNTab @  ldw A2,#t2Ready3 @  cpb SrcDrv,DstDrv beq 10$ ldw A2,#t2Ready4 10$: jsr YNBox cbi sysDBData,#$03 bne 12$ @  lda SrcDrv jsr SetDevice jsr GetFirstFile ; get a filename cpx #$00 bne 11$ jmp StartLNX 11$: jsr i_CNCLBox .word t2NoFile 12$: jmp HappyEnd  Co2Pack: lda SrcDrv 8X0 jsr SetDevice jsr GetNxtFile cpx #$00 bne 10$ jmp StartLNX ; A0 points 10$: jmp ContLNX $ff pla bra 35$ 31$: jsr GetSByte ; inspect the header cpx #0 beq 33$ 32$: rts 33$: cmp #$0d ; reading a by8X0 StartLNX: mvw A0,File lda SrcDrv jsr SetDevice jsr OpenDisk cpb SrcDrv,DstDrv beq 50$ ldw A2,#t2Copy mvw File,A3 jsr FileBar mvw File,A2 mvw File,A3 ldw A4,#$6000 ldw A5,#$7f00 mvb DstDrv,A6L jsr FileCopy cpx #0 beq 49$ 99$: jmp DiskError 49$: mvw FCOPdptr,R5 mvw FCOPdtns,R1 jsr SaveTabE lda DstDrv jsr SetDevice jsr OpenDisk bra 51$ 50$: mvw File,R6 ldb $886e,#$ff ; find source file jsr FindFile cpx #0 bne 99$ jsr SaveTabE  51$: inw NumFiles ldw A2,#t2Convert mvw File,A3 jsr FileBar mvw File,A2 jsr Convert cpx #0 bne 60$ jsr Imprint jmp Co2Pack 60$: cpx #$ff bne 99$ jsr Imprint jmp Co2Pack jsr GetSByte ; inspect the header cpx #0 beq 33$ 32$: rts 33$: cmp #$0d ; reading a by8X0 ContLNX: lda DstDrv jsr SetDevice jsr OpenDisk ldw A2,#FileName ldb A3L,#$00 ; don't confuse BEAP routines!! jsr CreatSF cpx #0 beq 23$ 22$: jmp DiskError 23$: ldw LastTNS,#$0000 ldw TotBlks,#0 jsr LNXhead cpx #0 bne 22$ ldw FNTabP,#FNTab jmp PackLNX 12$: jmp HappyEnd Co3Pack: avw #4,FNTabP cpw FNTabP,FNTabE bge 10$ jmp PackLNX 10$: ldw A2,#t2Clean ldw A3,#FileName jsr FileBar ldb A2L,#130 mvw SIOWFsize,HeadSize adw TotBlks,SIOWFsize ; make the right size jsr ClosSF cpx #0 bne 11$ jsr DoneLYNX beq 12$ 11$: jmp DiskError 12$: jsr i_OKBox .word t2Done  jmp HappyEnd  8X0 jsr NewDst jmp ShowDst ader cpx #0 beq 33$ 32$: rts 33$: cmp #$0d ; reading a by8X0 PackLNX: jsr GetLNXFile bne 99$  mvw DirPTR,R5 jsr SaveR5TS  ldw A2,#t2Lynx mvw File,A3 jsr FileBar  ldw FileBlocks,#0 lda LastTNS bne 11$ mvw ThisTNS,FirstTNS bra 20$ 11$: mvw ThisTNS,$8100 mvw LastTNS,R1 ldw R4,#$8100 jsr PutBlock ; do the LINKING! cpx #0 beq 20$ 99$: rts 20$: jsr PackLot bne 99$ lda RelTNS beq 70$ mvw RelTNS,$8100 mvw ThisTNS,R1 ldw R4,#$8100 jsr PutBlock ; Link REL to rest cpx #0 bne 99$ mvw RelTNS,ThisTNS ldw RelTNS,#0 jsr PackLot bne 99$ 70$: mvw ThisTNS,LastTNS jsr PutEntry bne 99$ jmp Co3Pack 12$ 11$: jmp DiskError 12$: jsr i_OKBox .word t2Done jsr NewSrc jsr ShowSrc jsr NewDst jmp ShowDst 35$ ldx A0H ; A0H has return code rts 35$: ldy A0L cmp 8X0 DoneLYNX: ldw R4,#$8100 mvw SIOWTnS,R1 jsr GetBlock cpx #0 beq 10$ 99$: rts 10$: mvw FirstTNS,$8100 jsr PutBlock ; re-save first block cpx #0 bne 99$ ldw R4,#$8100 mvw HeadTNS,R1 jsr GetBlock cpx #0 bne 99$ mvw HeadSize,A2 jsr DecToChr ldx #$62 11$: lda ChrBuf,y beq 15$ sta $8100,x inx iny bne 11$ 15$: ldw R4,#$8100 mvw HeadTNS,R1 jsr PutBlock ; re-save first block cpx #0 bne 99$ ldw A2,#FNTab ; start deleting everything 20$: cpw A2,FNTabE blt 30$ ldx #0 29$: rts 30$: ldy #0 lda (A2),y sta R1L iny lda (A2),y sta R1H ldw R4,#$8000 jsr GetBlock cpx #0 bne 29$ ldy #2 lda (A2),y sta R5L iny lda (A2),y sta R5H ldy #0 tya sta (R5),y jsr PutBlock cpx #0 bne 29$ avw #4,A2 bra 20$ 8X0 LNXhead: ldb SafeBuf,#0 ; write mostly full header 10$: ldy SafeBuf lda LYNXHead,y jsr PutSByte cpx #0 beq 12$ 11$: rts 12$: inc SafeBuf cbi SafeBuf, #125 blt 10$ mvw NumFiles,A2 jsr DecToChr 15$: ldy #0 lda (A2),y beq 20$ jsr PutSByte cpx #0 bne 11$ inw A2 bra 15$ 20$: jsr OutSPCR bne 11$ mvw SIOWTnS,HeadTNS ldx #0 rts LYNXHead: ; 125 bytes .byte $01,$08,$5b,$08,$0a,$00,$97,$35,$33,$32,$38,$30,$2c,$30,$3a ,$97 .byte $35,$33,$32,$38, $31,$2c, $30,$3a,$97,$36,$34,$36,$2c,$c2,$28,$31 .byte $36,$32,$29,$3a,$99,$22, $93,$11, $11, $11, $11,$11, $11,$11,$11, $22 .byte $3a,$99,$22,$20,$20,$20, $20,$20,$55,$53,$45,$20,$4c,$59,$4e,$58 .byte $20,$54,$4f,$20,$44,$49, $53,$53,$4f,$4c,$56,$45,$20,$54,$48,$49 .byte $53,$20,$46,$49,$4c,$45,$22,$3a,$89,$31,$30,$00,$00,$00,$0d,$20 .byte $20,$20,$20,$2a,$4c,$59,$4e,$58,$20,$58,$56,$20,$20,$42,$59,$20 .byte $57,$49,$4c,$4c,$20,$43,$4f,$52,$4c,$45,$59,$0d,$20 ,0 t2Copy: .byte 27,"Copying:",0 t2Lynx: .byte 27,"LYNXing:8X0 PackLot: 20$: inw FileBlocks ; loop through file blocks inw  TotBlks mvw ThisTNS,R1 ldw R4,#$8100 jsr GetBlock cpx #0 bne 99$ lda $8100 beq 30$ mvw $8100,ThisTNS bra 20$ 30$: ldx #0 99$: rts (A2),y8X0 FixFNam: ldw A0,#FileName 10$: ldy #0 lda (A0),y beq 16$ cmp #'.' bne 15$ inw A0 lda (A0),y beq 16$ cmp #'L' beq 11$ cmp #'l' bne 15$ 11$: rts 15$: inw A0 bra 10$ rts 16$: ldw A4,#t2fnExt ; needs extension 17$: lda (A4),y ; copy extension sta (A0),y beq 11$ iny bne 17$ rts t2fnExt: .byte ".LNX",0 X",0 eadTNS ldx #0 rts LYNXHead: ; 125 bytes .byte $01,$08,$5b,$08,$0a,$00,$97,$35,$33,$32,$38,$30,$2c,$30,$3a ,$97 .byte $35,$33,$32,$38, $31,$2c, $30,$3a,$978X0 GetLNXFile: ldw RelTNS,#0 mvw FNTabP,A0 ldy #0 lda (A0),y sta R1L iny lda (A0),y sta R1H ldw R4,#$8000 jsr GetBlock cpx #0 beq 10$ rts 10$: ldy #2 lda (A0),y sta R5L iny lda (A0),y sta R5H mvw R5,DirPTR ldy #3 20$: lda (R5),y beq 30$ cmp #$a0 beq 30$ sta FNBuf-3,y iny cpy #$13 blt 20$ 30$: lda #0 sta FNBuf-3,y ldw File,#FNBuf ldy #0 lda (R5),y and #$1f cmp #$04 bne 70$ mvw ThisTNS,RelTNS ldy #$13 lda (R5),y sta ThisTNS iny lda (R5),y sta ThisTNS 70$: ldx #0 rts : ldx #0 rts ,$3a,$99,$22, $93,$11, $11, $11, $11,$11, $11,$11,$11, $22 .byte $3a,$99,$22,$20,$20,$20, $20,$20,$55,$53,$45,$20,$4c,$59,$4e,$58 .byte $20,$54,$4f,$20,$44,$49, $53,$53,$4f,$4c,$56,$45,$20,$54,$48,$49 .byte $8X0 DecToChr: ldy #0 ; value in A2, returns Y index lda #'0' ; into ChrBuf 10$: sta ChrBuf,y iny cpy #3 blt 10$ ldy #0 11$: cwi A2,#100 blt 20$ lda ChrBuf,y add #1 sta ChrBuf,y svw #100,A2 bra 11$ 20$: iny 21$: cwi A2,#10 blt 30$ lda ChrBuf,y add #1 sta ChrBuf,y svw #10,A2 bra 21$ 30$: iny 31$: lda A2L ; the ones place clc adc ChrBuf,y sta ChrBuf,y 40$: iny lda #0 sta ChrBuf,y ldy #0 ldw A2,#ChrBuf 45$: lda ChrBuf,y cmp #'0' bne 50$ iny inw A2 bra 45$ 50$: rts $93,$11, $11, $11, $11,$11, $11,$11,$11, $22 .byte $3a,$99,$22,$20,$20,$20, $20,$20,$55,$53,$45,$20,$4c,$59,$4e,$58 .byte $20,$54,$4f,$20,$44,$49, $53,$53,$4f,$4c,$56,$45,$20,$54,$48,$49 .byte $53,$20,$46,$49,$4c,$45,$22,$3a,$89,$31,$30,$00,8X0 ChrToDec: ldw A2,#0 ldy #$ff 10$: iny lda ChrBuf,y bne 10$ 15$: cpy #0 bne 20$ 19$: rts 20$: dey ; 1s first 21$: lda ChrBuf,y cmp #'0' ble 30$ inw A2 lda ChrBuf,y sub #1 sta ChrBuf,y bra 21$ 3 0$: cpy #0 beq 19$  dey ; 10s next 8X031$: lda ChrBuf,y cmp #'0' ble 40$ avw #10,A2 lda ChrBuf,y sub #1 sta ChrBuf,y bra 31$ 4 0$: cpy #0 beq 19$  dey ; 100s last  41$: lda ChrBuf,y 8X0 cmp #'0' ble 50$ avw #100,A2 lda ChrBuf,y sub #1 sta ChrBuf,y bra 41$ 50$: rts 0,$55,$53,$45,$20,$4c,$59,$4e,$58 .byte $20,$54,$4f,$20,$44,$49, $53,$53,$4f,$4c,$56,$45,$20,$54,$48,$49 .byte $53,$20,$46,$49,$4c,$45,$22,$3a,$89,$31,$30,$00,8X0 PutEntry: mvw File,A2 jsr PutSString cpx #0 bne 99$ jsr OutCR bne 99$ jsr OutSpace bne 99$ mvw FileBlocks,A2 jsr DecToChr jsr PutSString cpx #0 bne 99$ jsr OutSPCR bne 99$ lda TypeInfo jsr PutSByte cpx #0 bne 99$ jsr OutSPCR bne 99$ lda RelInfo beq 10$ jsr OutSpace bne 99$ ldb A2H,#0 mvb RelInfo,A2L jsr DecToChr jsr PutSString cpx #0 bne 99$ jsr OutSPCR bne 99$ 10$: jsr OutSpace bne 99$ ldb A2H,#0 mvb $8101,A2L jsr DecToChr jsr PutSString cpx #0 bne 99$ jsr OutSPCR 99$: rts rts 1,$11, $22 .byte $3a,$99,$22,$20,$20,$20, $20,$20,$55,$53,$45,$20,$4c,$59,$4e,$58 .byte $20,$54,$4f,$20,$44,$49, $53,$53,$4f,$4c,$56,$45,$20,$54,$48,$49 .byte $53,$20,$46,$49,$4c,$45,$22,$3a,$89,$31,$30,$00,8X0 SaveR5TS: ldy #1 lda (R5),y sta ThisTNS iny lda (R5),y sta ThisTNS+1 ldw RelInfo,#0 ldy #0 lda (R5),y and #$1f tay lda TypeTab,y sta TypeInfo cmp #'R' bne 10$ ldy #21 lda (R5),y ; relative file info sta RelInfo 10$: rts TypeTab: .byte 'D','S','P','U','R','C','I' TypeTab2: .byte $80,$81,$82,$83,$84,$85,$86 L jsr DecToChr jsr PutSString cpx #0 bne 99$ jsr OutSPCR bne 99$ 10$: jsr OutSpace bne 99$ ldb A2H,#0 mvb $8101,A2L jsr DecToChr jsr PutSStri8X0 SaveTabE: mvw FNTabE,A0 ldy #0 lda R1L sta (A0),y iny lda R1H sta (A0),y iny lda R5L sta (A0),y iny lda R5H sta (A0),y  avw #4,FNTabE rts  8X0 y ; relative file info sta Rel8X0 OutSpace: lda #32 jsr PutSByte cpx #0 rts OutCR: lda #13 jsr PutSByte cpx #0 rts OutSPCR: jsr OutSpace bne 10$ jsr OutCR 10$: rts  X0  CTOR: ; for fun TotBlk8X0 .ramsect TRACK: ; for fun SECTOR: ; for fun TotBlks: .block 2 ; total number of LYNXed blocks SafeBuf: .block 10 ; for saving registers File: .block 2 ; the file being worked on DirTNS: .block 2 ; This files directory TNS DirPTR: .block 2 ; This files directory pointer NumFiles: .block 2 ; duh FNTabE: .block 2 ; end of file pointer table FNTabP: .block 2 ; current file pointer ChrBuf: .block 10 ; buffer of dectoascii HeadTNS: .block 2 ; track and sector of lynx head HeadSize: .block 2 ; number of head blocks FirstTNS: .block 2 ; first file tns ThisTNS: .block 2 ; work tracknsector pointer LastTNS: .block 2 ; last file tns RelTNS: .block 2 ; relative file tns RelInfo: .block 2 ; relative file info TypeInfo: .block 1 ; file type RelBlocks: .block 2 ; total side sector blocks FileBlocks: .block 2 ; number of blocks in file FileLSize: .block 2 ; number of bytes in last block FNTab: .block 400*4 ; 4 bytes per file FNBuf: .block 30 ; filename bufferte $18,"Copy and de-LYNXS/9gbARKBPRG formatted GEOS file V1.0AWrite Image V2.0geoWrite V2.1  ...݅ ( >1 59 ..  9 < <` " . r " `(@1ʎsAڢ9 V&{`t -E-$^8X ;***************************** ;* ;*  geoBEAP II ;* "Bo's Excellent Archive Program" ;* ;* (C) 2001 Bo Zimmerman ;* ;* Dedicated to Naomi Zimmerman ;*****************************  .if Pass1 8X .noeqin .noglbl  .include GEOSequates .eqin .glbl .endif  .psect jmp Go2ARK ; VPRGbase + 0 0 + 0 jmp AbtBox ; VPRGbase + 3 s.rel APIcommon.rel MODflist.rel MODferr.rel MODscrn.rel MODseqR.rel MODseqW.rel MODvPrg.rel .mod8X0 Go2ARK: lda PackUnpack beq 11$ jmp Go2Unpack 11$: jmp Go2Pack lbl .endif  .psect jmp Go2ARK ; VPRGbase + 0 8X0 @;**************************************************** Go2Unpack:  cpb SrcDrv,DstDrv bne 90$ jsr numPicked cpx #1 bgt 13$ 90$: jsr GetFirstFile ; get a filename cpx #$00 bne 11$ ldw A2,#t2Ready1 @  cpb SrcDrv,DstDrv beq 10$ ldw A2,#t2Ready2 10$: jsr YNBox cbi sysDBData,#$03 bne 12$ @  lda SrcDrv jsr SetDevice jmp StartUnARK 11$: jsr i_CNCLBox .word t2NoDFile 12$: jmp HappyEnd 13$: jsr i_CNCLBox .word t2NoMulti bra 12$ Co2Unpack: @  cpb SrcDrv,DstDrv beq 10$ lda SrcDrv jsr SetDevice jsr GetNxtFile cpx #00 bne 10$ jmp StartUnARK 10$: jsr i_OKBox .word t2Done  jmp HappyEnd  t2Done: .byte $18,"Operation Complete",27,0 8X0t2NoDFile: .byte $18,"Select a file to unpack.",27,0 t2NoMulti: .byte $18,"Select only one (1) file.",27,0 t2NoFile: .byte $18,"Select one or more files.",27,0 t2Ready1: .byte $18,"Ready to de-ARK file?",27,0 t2Ready2: .byte $18,"Copy and de-ARK file?",27,0 t2Ready3: .byte $18,"Ready to ARK file(s)?",27,0 t2Ready4: .byte $18,"Copy and ARK file(s)?",27,0 t2BadFile: .block 100 t2BadMs1: .byte 34," is not ARKed!",27,0 t2Copy: .byte 27,"Copying:",0 t2Ark: .byte 27,"ARKing:",0 t2Clean: .byte 27,"Closing:",0 t2DeArk: .byte 27,"De-ARKing:",0 t2Convert: .byte 27,"Converting:",0 t2UnConvert: .byte 27,"Unconverting:",0 t2UnLink: .byte 27,"Re-linking:",0 0 : .byte 27,"Re-linking:",0 ",0 ",0 ",0 ",0 ",0 cmp #$02 ; have we seen three now? bne 59$ ; no, so keep going... lda Repeats ; two or8X0 StartUnARK: mvw A0,File ldw FNTabE,#$6000 lda SrcDrv jsr SetDevice jsr OpenDisk cpb SrcDrv,DstDrv beq 50$ ldw A2,#t2Copy mvw File,A3 jsr FileBar mvw File,A2 mvw File,A3 ldw A4,#$6000 ldw A5,#$7f00 mvb DstDrv,A6L jsr FileCopy cpx #0 beq 50$ 48$: jmp DiskError 50$: lda DstDrv jsr SetDevice jsr OpenDisk mvw File,A2 ldb A3L,#$ff jsr OpenSF cpx #0 bne 48$ mvw $8401,HeadTNS jsr isARK beq 60$ 59$: jmp notARK 60$: jsr findLHead bne 62$ 61$: jsr deARK beq 65$ cpx #$ff beq 59$ 62$: jmp DiskError 65$: dew NumFiles cwi NumFiles,#0 bne 61$ jsr doneDARK bne 62$ jsr Imprint jmp Co2Unpack r i_OKBox .word t2Done jsr NewSrc jsr ShowSrc jsr NewDst jmp ShowDst t2Done: .byte $18,"Operation Complete8X0 deARK: ldb R10L,#0 jsr GetFreeDirBlk ; now find a directory entry cpx #0 beq 10$ ; a error getting dir entry! 90$: rts 10$: sty DirPTR ; store index for safe keeping sty DirPTR+1 mvw R1,DirTNS jsr GetSByte cpx #0 bne 90$ ldy DirPTR sta $8000,y ; FileType and #$1f sta TypeInfo inc DirPTR jsr GetSByte cpx #0 bne 90$ sta FileLSize ; got last sector size cmp #0 beq 23$ ldy DirPTR lda ThisTNS ; store start tns sta $8000,y iny lda ThisTNS+1 sta $8000,y iny ldb A0L,#0 20$: sty DirPTR ; store index for safe keeping jsr GetSByte cpx #0 bne 90$ ldy DirPTR sta $8000,y cmp #0 beq 23$ ldx A0L sta FNBuf,x cmp #$a0 bne 21$ lda #0 sta FNBuf,x 21$: iny inc A0L cbi A0L,#$10 blt 20$ sty DirPTR ; store index for safe keeping lda FNBuf beq 23$ ldw A2,#t2DeArk ldw A3,#FNBuf jsr FileBar cwi ThisTNS,#0 bne 30$ 23$: ldx #$ff 99$: rts 30$: ldy DirPTR lda #0 sta $8000,y ; no rel ss info for now iny sta $8000,y iny sty DirPTR jmp deARK2 RK f8X0 deARK2: jsr GetSByte cpx #0 bne 99$ sta RelInfo ; the record size ldy DirPTR sta $8000,y inc DirPTR ldb A0H,#6 20$: jsr GetSByte cpx #0 bne 99$ ; get "unused" by