10REM Program to do an efficient *COMPACT
   20REM Leaves no free spaces even on an extremely fragmented disc
   30REM Algorithm and coding (C) John Robinson 1988
   40REM The algorithm's really very simple. Why hasn't anybody ever thought
   50REM of it before?
   60:
   70REM Algorithm: Do compact similar to DFS, but change start sector
   80REM addresses recursively
   90:
  100A%=0:Y%=0:U%=USR(&FFDA) AND &FF
  110IF U%<>8 THEN PRINT "Not on ADFS"
  120:
  130MODE 135
  140HIMEM=HIMEM-&200
  150:
  160PROCinitialise_1
  170PROCnew_table
  180PROCchange_start_sectors
  190:
  200CLEAR
  210PROCinitialise_2
  220PROCcompact_disc
  230PROCnew_fsm
  240:
  250PROCterminate
  260:
  270END
  280:
  290DEFPROCinitialise_1
  300INPUT "Drive? " drive$
  310OSCLI "DIR :"+drive$
  320fsm=HIMEM
  330DIM dir &500,c &E,oldaddr &100,newaddr &100
  340PROCread_disc(fsm,0,&200)
  350CLS
  360PRINTTAB(0,6);
  370VDU 141,136
  380PRINT
  390VDU 141,136
  400PRINTTAB(11,6);"DO NOT PRESS BREAK"
  410PRINTTAB(11,7);"DO NOT PRESS BREAK"
  420PRINT
  430PRINT
  440PRINT "       The disc is currently in an"
  450PRINT "     inconsistent state and will be"
  460PRINT "  unreadable if the program is left now"
  470PRINT
  480PRINT
  490PRINT "   Changing start sector addresses...";
  500REM *FX 229 1
  510REM *FX 230 1
  520ENDPROC
  530:
  540DEFPROCnew_table
  550!oldaddr=7
  560!newaddr=7
  570fs_total=0
  580FOR offset=0 TO ?(fsm+&1FE)-3 STEP 3
  590fs_len=FNrd_3byte(fsm+offset+&100)
  600oldaddr!(offset+3)=FNrd_3byte(fsm+offset)+fs_len
  610fs_total=fs_total+fs_len
  620newaddr!(offset+3)=oldaddr!(offset+3)-fs_total
  630NEXT offset
  640fs_table_len=?(fsm+&1FE)-3
  650F%=fs_total
  660ENDPROC
  670:
  680DEFPROCread_disc(dest_addr,start_sec,length)
  690PROCaccess_disc(&8)
  700ENDPROC
  710:
  720DEFPROCwrite_disc(dest_addr,start_sec,length)
  730PROCaccess_disc(&A)
  740ENDPROC
  750:
  760DEFPROCaccess_disc(code)
  770?c=0
  780c!1=dest_addr
  790c?5=code
  800c?6=start_sec DIV &10000
  810c?7=(start_sec DIV &100) MOD &100
  820c?8=start_sec MOD &100
  830c!9=0
  840c!11=length
  850Y%=c DIV 256
  860X%=c MOD 256
  870A%=&72
  880CALL &FFF1
  890IF ?c<>0 THEN PROCdisc_error
  900ENDPROC
  910:
  920DEFPROCdisc_error
  930A%=&73
  940CALL &FFF1
  950PRINT '"Disc error ";~c?3;" at :";(!c DIV &200000) MOD 8;"/";!c MOD &200000
  960END
  970:
  980DEFFNrd_3byte(addr) =!addr AND &FFFFFF
  990DEFPROCwr_3byte(addr,data)
 1000!addr=(!addr AND &FF000000) OR data
 1010ENDPROC
 1020:
 1030DEFPROCchange_start_sectors
 1040PROCscan(2)    :REM 2 is start sector of $ dir
 1050ENDPROC
 1060:
 1070DEFPROCscan(diraddr) LOCAL dirptr
 1080PROCload_dir(diraddr)
 1090dirptr=dir+5
 1100REPEAT
 1110IF (dirptr?3 AND &80) ELSE GOTO 1150    :REM I use this to implement
 1120PROCsave_dir(diraddr)                   :REM multi-line IF
 1130PROCscan(FNrd_3byte(dirptr+22))
 1140PROCload_dir(diraddr)
 1150start_sec=FNchange_addr(FNrd_3byte(dirptr+22))
 1160PROCwr_3byte(dirptr+22,start_sec)
 1170dirptr=dirptr+26
 1180UNTIL ?dirptr=0
 1190PROCwr_3byte(dir+&4D6,FNchange_addr(FNrd_3byte(dir+&4D6)))
 1200PROCsave_dir(diraddr)
 1210ENDPROC
 1220:
 1230DEFFNchange_addr(n) LOCAL change_addr
 1240FOR change_addr=fs_table_len TO 0 STEP -3
 1250IF n>=FNrd_3byte(oldaddr+change_addr) THEN n=n-FNrd_3byte(oldaddr+change_addr)+FNrd_3byte(newaddr+change_addr):change_addr=-3                                    :REM I use this to terminate a loop quickly
 1260NEXT change_addr
 1270=n
 1280:
 1290DEFPROCload_dir(diraddr)
 1300PROCread_disc(dir,diraddr,&500)
 1310ENDPROC
 1320:
 1330DEFPROCsave_dir(diraddr)
 1340PROCwrite_disc(dir,diraddr,&500)
 1350ENDPROC
 1360:
 1370DEFPROCinitialise_2
 1380fsm=HIMEM
 1390n_of_secs=(HIMEM-LOMEM-&400) DIV &100
 1400DIM data n_of_secs*&100
 1410PRINT ;CHR$(&D);STRING$(39," ");
 1420PRINT ;CHR$(&D);"       Relocating data on disc..."
 1430DIM c &E
 1440ENDPROC
 1450:
 1460DEFPROCcompact_disc
 1470data_total=FNrd_3byte(fsm+&FC)-F%  :REM F%=fs_total
 1480dest_sec=FNrd_3byte(fsm)
 1490src_sec=dest_sec+FNrd_3byte(fsm+&100)
 1500load_sec=src_sec
 1510fsm_ptr=3
 1520data_finished=FALSE
 1530PROCpercentage
 1540REPEAT
 1550secs_in_mem=0
 1560memoffs=0
 1570REPEAT
 1580PROCread_a_sector
 1590UNTIL secs_in_mem=n_of_secs OR data_finished
 1600PROCwrite_memory
 1610PROCpercentage
 1620UNTIL data_finished
 1630PRINT ;CHR$(&D);STRING$(39," ");CHR$(&B);
 1640ENDPROC
 1650:
 1660DEFPROCread_a_sector
 1670secs_in_mem=secs_in_mem+1
 1680src_sec=src_sec+1
 1690IF secs_in_mem=n_of_secs THEN PROCupdate_memory:load_sec=src_sec
 1700IF FNrd_3byte(fsm+fsm_ptr)=src_sec THEN PROCupdate_memory:src_sec=src_sec+FNrd_3byte(fsm+fsm_ptr+&100):load_sec=src_sec:fsm_ptr=fsm_ptr+3:IF fsm_ptr=fsm?&1FE THEN data_finished=TRUE
 1710ENDPROC
 1720:
 1730DEFPROCupdate_memory
 1740PROCread_disc(data+memoffs*&100,load_sec,(src_sec-load_sec)*&100)
 1750memoffs=memoffs+src_sec-load_sec
 1760update=NOT TRUE
 1770ENDPROC
 1780:
 1790DEFPROCwrite_memory
 1800PROCwrite_disc(data,dest_sec,secs_in_mem*&100)
 1810dest_sec=dest_sec+secs_in_mem
 1820ENDPROC
 1830:
 1840DEFPROCpercentage LOCAL Z%
 1850Z%=dest_sec/data_total*100
 1860PRINT ;CHR$(&D);TAB(15);STRING$(3-LEN STR$Z%," ");Z%;"% done";
 1870ENDPROC
 1880:
 1890DEFPROCnew_fsm
 1900PRINT ;CHR$(&D);"     Creating new free space map...";
 1910FOR ptr=0 TO 245
 1920fsm?ptr=0
 1930fsm?(ptr+&100)=0
 1940NEXT ptr
 1950PROCwr_3byte(fsm,data_total)
 1960PROCwr_3byte(fsm+&100,F%)
 1970fsm?&1FE=3
 1980fsm?&FF=FNchecksum(fsm)
 1990fsm?&1FF=FNchecksum(fsm+&100)
 2000PROCwrite_disc(fsm,0,&200) 
 2010ENDPROC
 2020:
 2030DEFFNchecksum(addr)
 2040FOR pass=0 TO 2 STEP 2
 2050P%=data
 2060[OPT pass
 2070.checksum
 2080CLC
 2090LDY #&FF
 2100TYA
 2110.loop
 2120ADC addr-1,Y
 2130DEY
 2140BNE loop
 2150RTS
 2160]
 2170NEXT pass
 2180=USR(checksum) AND &FF
 2190:
 2200DEFPROCterminate
 2210*DIR $
 2220*FX 229
 2230*FX 230
 2240CLS
 2250PRINTTAB(0,11);
 2260VDU 141,136
 2270PRINT
 2280VDU 141,136
 2290PRINTTAB(14,11);"ALL FINISHED"
 2300PRINTTAB(14,12);"ALL FINISHED"
 2310VDU 30
 2320ENDPROC
 2330: