Transactor/Transactor_27_1988_Transactor_Publishing.d64/ml.sda/HUFF.SRC

Commodore BASIC | 2023-02-26 | 10KB | 342 lines

10 rem save"huff.src"
20 sys700
30 *=49152
40 .opt oo
50 fstat = $90; file status
100 getin = $ffe4
101 chkin = $ffc6
102 chrin = $ffcf
103 clrchn = $ffcc
104 close = $ffc3
105 chkout = $ffc9
106 chrout = $ffd2
149 bb = $c500
150 cfreqlo = bb+0;  characters' frequency
151 cfreqhi = bb+$100
152 ccode = bb+$200; code (00=0, ff=1)
153 cpnode = bb+$300;  parent node
154 nfreqlo = bb+$400;  nodes' freq
155 nfreqhi = bb+$500
156 ncode = bb+$600; code
157 npnode = bb+$700; parent (0=top)
158 list = bb+$800;  sorted list
159 type = bb+$900;  type 00=char, ff=node
160 hbits = bb+$a00;  my own stack
170 ch0type = bb+0;  reused variable space--child 0 type
172 ch0name = bb+$100;  child 0 name
174 ch1type = bb+$200
176 ch1name = bb+$300
200 jmp epass1; encode pass one
210 jmp epass2; encode pass two
220 jmp decode; decode
230 ;
250 epass1 = *
260 ldx #2:jsr chkin;  open channel 2 for input
265 jsr zeromem;  zero out memory
270 jsr countem;  count the bytes
272 lda #2:jsr close:jsr clrchn;  close up channel 2
275 jsr sortem;  sort the list
280 jsr maketree;  build the tree
285 jsr node0;  the tip of the tree
290 rts
299 ;
300 zeromem = *
310 lda #0:tay
320 zeloop sta cfreqlo,y
321 sta cfreqhi,y
322 sta ccode,y
323 sta cpnode,y
324 sta ncode,y
325 sta type,y
326 sta list,y
327 dey:bne zeloop
330 sta filelen:sta filelen+1:sta numchar:sta numnode
335 inc numnode;  save node 0 for the top
340 rts
349 ;
350 countem = *
360 jsr chrin;  get a character from disk
364 tax;  index by .x
366 inc cfreqlo,x;  one more in that slot
368 bne bytecount:inc cfreqhi,x;  if 0, then inc the high byte
370 bytecount inc filelen:bne cotest:inc filelen+1
380 cotest ldy fstat; file status (0 = more to come)
382 beq countem;  (NULL) back for more bytes
383 ldx filelen:lda filelen+1:jsr $bdcd:lda #62:jsr chrout; print length, >
384 rts;
399 ;
400 sortem = *
410 ldy #0
412 sty listlen;  used by the isort routine
413 sty lc
415 soloop ldy lc:lda cfreqlo,y:ora cfreqhi,y;  check if freq <> 0
416 beq nochar;  if eq, then no characters
418 tya;  add it to the list
420 ldy numchar:sta list,y;  this is the ascii code
422 inc numchar;  one more character
424 jsr isort;  insertion sort
426 inc listlen;  the list has one more member
428 nochar inc lc:bne soloop;  keep (NULL)ing with lc 0 to 255
430 rts
440 isort = *
450 ldy listlen;  length of the list
452 bne is01;
454 rts;  if = 0, skip this
456 is01 lda list,y:sta islist:tax:lda type,y:sta istype;  save these values
458 bne anode;  if <>0, it's a node
460 lda cfreqlo,x:sta islo:lda cfreqhi,x:sta ishi; save frequencies
462 jmp is02;  (NULL) compare them
464 anode lda nfreqlo,x:sta islo:lda nfreqhi,x:sta ishi; save frequencies
466 is02 = *
468 dey;  count backward in the list
470 ldx list,y:lda type,y
472 bne anode2;  another node
474 lda cfreqlo,x:sta testlo:lda cfreqhi,x:sta testhi:jmp is03
476 anode2 lda nfreqlo,x:sta testlo:lda nfreqhi,x:sta testhi
478 is03 = *
480 lda ishi:cmp testhi;  compare
482 bcc insert;  insert in the list here
484 bne is04;  keep looping, maybe
486 lda islo:cmp testlo;  not sure, so check low byte
488 beq insert;  if equal, insert
490 bcc insert;  if islo < testlo, insert
492 ;  else drop through
494 is04 cpy #0:bne is02;  if .y = 0, drop through to insert
496 dey
498 insert = *
500 iny:sty tempy;  save the value
501 cpy listlen:bne doit:rts
502 doit ldy listlen;  start at the end
504 isloop dey:lda list,y:iny:sta list,y:dey
506 lda type,y:iny:sta type,y:dey
508 cpy tempy:bne isloop
510 lda islist:sta list,y:lda istype:sta type,y
512 rts
549 ;
550 maketree = *
560 ldx numchar:dex:stx listlen
565 mamain ldy listlen
570 jsr fixcn;  fix the codes & nodes for y and y-1
572 jsr fixfreq;  fix the new node's frequency
574 jsr addnode;  add the node to the list
576 jsr isort;  sort it
578 inc numnode
580 lda listlen:cmp #1:bne mamain;  quit when only two nodes remain
582 rts
584 fixcn = *
586 ldy listlen
588 lda #$ff;  this means code = 1
590 jsr fixsr;  set the code/node
591 dey:lda #0:jsr fixsr; code = 0 on the left
592 rts
600 fixsr ldx type,y:beq tsachar;  itsa char
601 ldx list,y
602 sta ncode,x;  it's a node
604 lda numnode:sta npnode,x:rts
606 tsachar ldx list,y:sta ccode,x:lda numnode:sta cpnode,x:rts
620 fixfreq = *
630 ldy listlen
632 ldx type,y:beq anotchar;  another char
634 ldx list,y:lda nfreqlo,x:sta low1:lda nfreqhi,x:sta hi1
636 jmp ahead
638 anotchar ldx list,y:lda cfreqlo,x:sta low1:lda cfreqhi,x:sta hi1
640 ahead dey:ldx type,y:beq itschar;  another char
642 ldx list,y:lda nfreqlo,x:sta low2:lda nfreqhi,x:sta hi2
644 jmp addem
646 itschar ldx list,y:lda cfreqlo,x:sta low2:lda cfreqhi,x:sta hi2
648 addem ldx numnode:clc:lda low1:adc low2:sta nfreqlo,x
650 lda hi1:adc hi2:sta nfreqhi,x
652 rts
654 ;
670 addnode = *
672 dec listlen
674 ldx listlen:lda #$ff:sta type,x;  type of a parent is always a node
676 lda numnode:sta list,x;  add the node number to the list
678 rts
699 ;
700 node0 = *
710 ldy #1
712 ldx list,y
714 lda #$ff:sta ncode,x
716 lda #0:sta npnode,x;  the parent is node 0 at the top
718 dey:ldx list,y
720 sta ncode,x:sta npnode,x
722 rts
799 ;
800 epass2 = *
812 ldx #4:jsr chkout;  channel 4 for writing
814 lda #0:sta outlen:sta outlen+1;  zero out file length
816 jsr header;  send the header bytes
818 jsr encfile;  send the encoded file
820 lda #4:jsr close:lda #3:jsr close
822 jsr clrchn
824 ldx outlen:lda outlen+1:jsr $bdcd;  print crunched length
826 rts
828 ;
840 header = *
850 lda filelen:jsr chrout:lda filelen+1:jsr chrout;  length of input file
852 ldy #0:ldx #0
854 char0 lda cfreqlo,x:ora cfreqhi,x;  is this char in file
855 beq head0;  if no freq, doesn't exist
856 lda ccode,x:bne head0;  ignore $ff
857 txa:sta hbits,y:iny;  push on temp stack
858 head0 inx:bne char0
859 tya:pha:jsr chrout:jsr sendchar;  send # of 0children and then names
860 ;
862 ldy #0:ldx #0
866 char1 lda ccode,x:beq head1;  ignore $00
867 txa:sta hbits,y:iny;  push on temp stack
868 head1 inx:bne char1
869 tya:pha:jsr chrout:jsr sendchar;  send # of 1children and then names
870 ;
872 ldy #0:ldx #1
876 pnode0 lda ncode,x:bne head2;  ignore $ff
877 txa:sta hbits,y:iny;  push on temp stack
878 head2 inx:cpx numnode:bne pnode0
879 tya:pha:jsr chrout:jsr sendnode;  send # of 0nodes and then names
880 ;
882 ldy #0:ldx #1
886 pnode1 lda ncode,x:beq head3;  ignore $00
887 txa:sta hbits,y:iny;  push on temp stack
888 head3 inx:cpx numnode:bne pnode1
889 tya:pha:jsr chrout:jsr sendnode;  send # of 1nodes and then names
890 ;
891 ldy #4
892 addloop pla:clc:adc outlen:sta outlen
893 lda #0:adc outlen+1:sta outlen+1:dey:bne addloop
894 asl outlen:rol outlen+1:clc:lda outlen:adc #6:sta outlen
895 lda #0:adc outlen+1:sta outlen+1:rts
896 ;
902 sendchar dey:ldx hbits,y:lda cpnode,x:jsr chrout;  send parent's name
903 txa:jsr chrout;  send name
904 cpy #0:bne sendchar:rts
905 ;
906 sendnode dey:ldx hbits,y:lda npnode,x:jsr chrout;  send parent's name
907 txa:jsr chrout;  send name
908 cpy #0:bne sendnode:rts
909 ;
950 encfile = *
960 inc filelen+1
970 lda #8:sta outbits;  8 bits in a byte
972 enloop jsr walkup;  walk up the tree
974 jsr walkdown;  output the byte
976 dec filelen:bne enloop
978 dec filelen+1:bne enloop;  keep (NULL)ing while the characters are coming
980 ldx outbits:cpx #8:beq finish
982 lastone asl outbyte:dex:bne lastone
984 ldx #4:jsr chkout:lda outbyte:jsr chrout;  send the last one
985 inc outlen:bne finish:inc outlen+1
986 finish rts
988 ;
990 walkup = *
1000 ldx #3:jsr chkin:jsr chrin:tax;  get the next input byte
1002 ldy #0
1004 lda ccode,x:sta hbits,y:iny;  first code
1006 lda cpnode,x:beq upout;  if parent is zero, exit
1008 uploop tax
1010 lda ncode,x:sta hbits,y:iny;  get the code and save it
1012 lda npnode,x:bne uploop;  branch if not parent 0
1014 upout dey:rts
1016 ;
1020 walkdown = *
1030 lda hbits,y
1032 rol:rol outbyte;  build a byte a bit at a time
1034 dec outbits
1036 beq (NULL)tabyte;  if outbits = 0, 8 bits are ready
1038 downtest dey:cpy #255:bne walkdown
1040 rts;  end of walkdown
1042 ;
1044 (NULL)tabyte sty tempy
1045 ldx #4:jsr chkout:lda outbyte:jsr chrout;  send a character
1046 ldy tempy:inc outlen;  increment length of output file
1048 bne reset8:inc outlen+1
1050 reset8 lda #8:sta outbits
1052 bne downtest;  branch always
1054 ;
1100 decode = *
1110 ldx #5:jsr chkin;  channel 5 is input
1120 jsr chrin:sta filelen:jsr chrin:sta filelen+1:inc filelen+1
1122 chi0 jsr chrin;  how many child0's
1124 beq chi1:sta lc;  loop counter
1126 delp1 jsr chrin:tax:jsr chrin
1128 sta ch0name,x:lda #0:sta ch0type,x
1129 dec lc:bne delp1
1130 ;
1132 chi1 jsr chrin;  how many child1's
1134 beq par0:sta lc;  loop counter
1136 delp2 jsr chrin:tax:jsr chrin
1138 sta ch1name,x:lda #0:sta ch1type,x
1139 dec lc:bne delp2
1140 ;
1142 par0 jsr chrin;  how many parent0's
1144 beq par1:sta lc;  loop counter
1146 delp3 jsr chrin:tax:jsr chrin
1148 sta ch0name,x:lda #$ff:sta ch0type,x
1149 dec lc:bne delp3
1150 ;
1152 par1 jsr chrin;  how many parent1's
1154 beq bitter:sta lc;  loop counter
1156 delp4 jsr chrin:tax:jsr chrin
1158 sta ch1name,x:lda #$ff:sta ch1type,x
1159 dec lc:bne delp4
1160 ;
1170 bitter = *
1180 lda #0:sta node
1182 outloop ldx #5:jsr chkin:jsr chrin
1184 sta huffer;  (NULL)t 8 bits
1188 lda #8:sta numbits
1190 inloop ldy node;  the node is the parent
1192 rol huffer;  get a bit into carry
1194 bcs itsa1;  if cs, the bit is 1
1196 itsa0 = *
1198 lda ch0name,y;  get the name of child 0
1200 sta node;  who is the new parent/node
1202 ldx ch0type,y;  does it terminate
1204 beq printit;  yes, (NULL) print
1206 nextbit = *
1208 dec numbits
1210 bne inloop
1212 beq outloop
1216 ;
1220 itsa1 = *
1222 lda ch1name,y;  get the name of child 1
1224 sta node;  who is the new parent/node
1226 ldx ch1type,y;  does it terminate
1228 beq printit;  yes, (NULL) print
1230 bne nextbit
1240 ;
1250 printit = *
1260 ldx #6:jsr chkout
1262 lda node:jsr chrout
1264 dec filelen:bne tothetop:dec filelen+1
1266 tothetop lda #0:sta node;  back up to node 0 at the top
1268 lda filelen:ora filelen+1:bne nextbit
1270 ;
1280 cleanup = *
1290 lda #5:jsr close:lda #6:jsr close
1292 jsr clrchn
1294 rts
1296 ;
9000 filelen = *;  length of src file
9002 numchar = *+2;  # of chars
9004 numnode = *+3;  # of nodes
9006 lc = *+4;  loop counter
9008 listlen = *+5;  length of list, used by isort routine
9010 islist = *+6;  temporary storage for list, type, freqlo, and freqhi
9012 istype = *+7
9014 islo = *+8
9016 ishi = *+9
9018 testlo = *+10;  islo/hi is tested against testlo/hi for insertion sort
9020 testhi = *+11
9022 tempy = *+12;  temp storage for .y
9024 low1 = islo
9026 hi1 = ishi
9028 low2 = testlo
9030 hi2 = testhi
9040 outlen = *+13;  output file length
9042 outbyte = *+15;  the (crunched) huffman byte to send out
9044 outbits = *+16;  number of bits (when it = 8, the byte gets sent)
9046 huffer = islo;  huffman byte (when uncrunching)
9048 node = ishi;  the child node (either another node or a char)
9050 numbits = testlo;  number of bits