home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / math / classdoc / rfp.a < prev    next >
Encoding:
Text File  |  1993-07-28  |  10.4 KB  |  722 lines
  1.  
  2.     ; The Redundance Fighter  Packer V1.20
  3.     ; written by Lutz Vieweg 1991
  4.  
  5.     include    src:class.mac
  6.  
  7. max_mem    equ    1024*128*2
  8. min_mem    equ    20
  9.  
  10. main    
  11.     textr    "HPHP48-E"
  12.     
  13.     rpl    Type_pgm
  14.     
  15.     rpl    Need_1_arg
  16.     
  17.     rpl    Dup
  18.     rpl    $5944    ; CRC nibbles
  19.     rpl    Drop
  20.     
  21.     include    "src:relocpgm.a"
  22.     
  23.     rpl    $02dcc
  24. pgmbeg    
  25.     rpl    pgmend-pgmbeg
  26.     
  27.     jsr    save_regs
  28.     
  29.     jsr    gc
  30.     
  31.     jsr    restore_regs
  32.     
  33.     move.ao    #stack_ptr,d0
  34.     exg.a    d1,c
  35.     move.a    c,d1
  36.     move.a    c,(d0)
  37.     
  38.     move.a    (d1),c
  39.     move.a    c,d0
  40.     add.a    #5,d0
  41.     move.a    (d0),c
  42.     move.ao    #old_len,d0
  43.     move.a    c,(d0)
  44.     
  45.     add.a    #5,d1
  46.     move.a    (d1),c
  47.     move.ao    #old_obj_adr,d0
  48.     move.a    c,(d0)
  49.     
  50.     jsr    restore_regs
  51.     
  52.     bsr    work_mem
  53.     
  54.     intoff
  55.     bclr    #15,st
  56.     
  57.     move.ao    #old_len,d0
  58.     move.a    (d0),a
  59.     move.a    #1000,c
  60.     blt.a    a,c,.1z
  61.     move.a    #$100,d0
  62.     move.1    (d0),c
  63.     bclr    #3,c
  64.     move.1    c,(d0)
  65. .1z    
  66.     
  67.     bsr    compress
  68.     bcc    .1
  69.     bra    .2
  70. .1    
  71.     jsr    restore_regs
  72.     
  73.     move.ao    #new_len,d0
  74.     move.a    (d0),c
  75.     jsr    blkalloc
  76.     exg.a    d0,c
  77.     
  78.     move.ao    #new_obj_adr,d0
  79.     move.a    c,(d0)
  80.     move.a    c,d1
  81.     move.ao    #new_len,d0
  82.     move.a    (d0),a
  83.     move.ao    #work_mem_adr,d0
  84.     move.a    (d0),c
  85.     move.a    c,d0
  86.     move.a    a,c
  87.     jsr    blkcopy
  88.     
  89.     move.ao    #stack_ptr,d0
  90.     move.a    (d0),c
  91.     move.a    c,d1
  92.     add.a    #5,d1
  93.     move.ao    #new_obj_adr,d0
  94.     move.a    (d0),c
  95.     move.a    c,(d1)
  96.     
  97. .2    
  98.     move.ao    #work_mem_adr,d0
  99.     move.a    (d0),c
  100.     move.a    c,d1
  101.     move.a    #$02dcc,c
  102.     move.a    c,(d1)
  103.     add.a    #5,d1
  104.     
  105.     move.ao    #work_mem_len,d0
  106.     move.a    (d0),c
  107.     sub.a    #5,c
  108.     move.a    c,(d1)
  109.     
  110. leave_code    
  111.     move.a    #$100,d0
  112.     move.1    (d0),c
  113.     bset    #3,c
  114.     move.1    c,(d0)
  115.     bset    #15,st
  116.     inton
  117.     
  118.     bclr    #$a,st
  119.     jsr    restore_regs
  120.     move.a    (d0),a
  121.     add.a    #5,d0
  122.     jmp    (a)
  123.  
  124. work_mem    
  125.     jsr    avail_mem
  126.     move.a    c,a
  127.     
  128.     lsr.a    #1,a    ; / 2 fuer zwei speicher
  129.     
  130.     move.a    #min_mem,c
  131.     bgt.a    a,c,.2
  132.     
  133.     pop
  134.     bra.4    leave_code
  135. .2    
  136.     move.ao    #work_mem_len,d0
  137.     move.a    a,(d0)
  138.     
  139.     move.a    a,c
  140.     jsr    blkalloc
  141.     exg.a    d0,c
  142.     
  143.     move.ao    #work_mem_adr,d0
  144.     move.a    c,(d0)
  145.     
  146.     rtn
  147.  
  148. compress    
  149.     move.ao    #old_obj_adr,d0
  150.     move.a    (d0),a
  151.     move.a    #$70000,c
  152.     bge.a    a,c,.1
  153.     
  154.     rtnsc
  155.     
  156. .1    
  157.     move.a    a,r3        ;source adr
  158.     move.ao    #last_norm,d0
  159.     move.a    a,(d0)
  160.     move.ao    #old_len,d0
  161.     move.a    (d0),c
  162.     move.a    c,r4
  163.     
  164.     move.ao    #work_mem_adr,d0    ; archiv-kennzeichen
  165.     move.a    (d0),a        ; anbringen
  166.     move.a    a,d1
  167.     move.a    #$02a2c,c
  168.     move.a    c,(d1)
  169.     add.a    #5,d1
  170.     exg.a    d1,c
  171.     move.a    c,d1
  172.     move.ao    #strlen_adr,d0
  173.     move.a    c,(d0)
  174.     add.a    #5,d1
  175.     move.a    #$24652,c        ; !v
  176.     move.a    c,(d1)
  177.     add.a    #5,d1
  178.     move.ao    #old_len,d0
  179.     move.a    (d0),c
  180.     move.a    c,(d1)
  181.     add.a    #5,d1
  182.     exg.a    d1,c
  183.     move.ao    #work_mem_len,d0
  184.     move.a    (d0),a
  185.     sub.a    #10,a    ; fuer $02a2c und laenge
  186.     sub.a    #7,a    ; 5 fuer zeichen, 2 fuer code
  187.     sub.a    #5,a    ; 5 fuer alte laenge
  188.     move.ao    #mem_left,d0        ; mem_left setzen
  189.     move.a    a,(d0)
  190.     
  191.     move.ao    #last_code_adr,d0
  192.     move.a    c,(d0)
  193.     add.a    #2,c
  194.     move.ao    #dest_adr,d0
  195.     move.a    c,(d0)        ; dest adr
  196.     move.x    #$800,c
  197.     move.x    c,d    ; dest counter und data
  198.     
  199.     clr.s    d
  200.     dec.s    d        ; muss auf anfang pruefen
  201.     
  202.     ;------------------------------------------------
  203. nextnib    
  204.     move.a    r3,a
  205.     move.a    a,d0
  206.     move.a    (d0),c
  207.     move.a    c,b    ; fuer suchen des ersten nibs
  208.     
  209.     move.a    #256,c
  210.     sub.a    c,a
  211.     beq.s    d,0,.2    ; kein pruefen auf anfang noetig?
  212.     ; doch
  213.     move.ao    #old_obj_adr,d0
  214.     move.a    (d0),c
  215.     blt.a    a,c,.3    ;geht nicht...
  216.     inc.s    d    ;nicht mehr pruefen
  217.     bra    .4
  218. .3    
  219.     move.a    c,a
  220. .4    
  221. .2    
  222.     ; in a.a ist jetzt die adresse, ab der verglichen werden soll
  223.     ; in b.b ist das byte, das auch an der akt. source ist
  224.     
  225.     move.a    a,r2    ; adresse fuer vergleich
  226.     move.a    r3,c
  227.     sub.a    a,c    ; zaehler fuer noch sinnvolle suche
  228.     move.a    c,a    ; in a
  229.     
  230.     clr.b    c
  231.     move.b    c,r0    ; beste laenge, da drunter nix ist
  232.     
  233.     dec.a    a
  234.     bcc    .5    ; wenn vergleich nix bringt, dann wech
  235.     bra    hunt_fini
  236. .5    
  237.     move.a    r2,c
  238.     move.a    c,d0
  239. .8    
  240.     move.a    (d0),c
  241.     beq.a    c,b,.7    ; gleiches byte gefunden?
  242.     add.a    #1,d0
  243. .12            ;hier weiter suchen
  244.     dec.x    a    ; sollte reichen, sonst .a
  245.     bcc    .8
  246.     bra    hunt_fini
  247. .7    
  248.     exg.a    d0,c
  249.     inc.a    c
  250.     move.a    c,d0
  251.     move.a    c,r2    ; hier weiter vergleichen
  252.     
  253.     ; jetzt muss d0... mit source... verglichen werden
  254.     
  255.     move.a    r3,c    ; source
  256.     move.a    c,d1    ; nach d1
  257.     add.a    #5,d1
  258.     add.a    #4,d0
  259.     
  260.     move.a    #43,c
  261.     move.a    c,b    ; zaehler fuer max field-len
  262.     move.a    r4,c    ; nibs_left
  263.     bge.a    c,b,.10m
  264.     move.a    c,b
  265. .10m    
  266.     move.b    #5,c    ; neue beste? laenge
  267.     sub.b    #6,b    ; weil schon 1 lang und 0
  268.     bcs    .9
  269. .10    
  270.     move.s    (d1),c
  271.     move.s    (d0),a
  272.     bne.s    c,a,.9    ; ungleich, vergleich beenden
  273.     
  274.     add.a    #1,d0
  275.     add.a    #1,d1
  276.     
  277.     inc.b    c
  278.     dec.b    b    ; max_field_len noch nicht ueber?
  279.     bcc    .10
  280. .10i    
  281.     ; wenn doch, suche abbrechen und bestes setzen...
  282.     move.b    c,r0    ;beste laenge
  283.     move.a    r2,c
  284.     dec.a    c
  285.     move.a    c,r1    ;adresse des besten
  286.     bra    hunt_fini
  287. .9    
  288.     ;vergleich ist beendet, in c.b ist gefundene laenge
  289.     ; b wird jetzt nicht mehr gebraucht
  290.     move.b    c,b
  291.     move.b    r0,c
  292.     blt.b    b,c,.11    ; ist neues feld groesser?
  293.     ; ja, setzen!
  294.     move.b    b,c
  295.     move.b    c,r0    ;laenge und...
  296.     move.a    r2,c
  297.     dec.a    c
  298.     move.a    c,r1    ; adresse des neuen besten setzen
  299. .11    
  300.     ; jetzt weiter suchen...
  301.     
  302.     move.a    r3,c
  303.     move.a    c,d0
  304.     move.a    (d0),c    ; such-byte von source
  305.     move.a    c,b
  306.     
  307.     move.a    r2,c
  308.     move.a    c,d0    ; suchadresse...
  309.     
  310.     bra    .12    ; weiter suchen
  311.     
  312. hunt_fini    ; jetzt steht die beste folge fest:
  313.     ; in r0.b ist ihre laenge, in r1.a ihre adresse.
  314.     ; folgende register sind noch von bedeutung:
  315.     ; r3=source_adr  r4=nibs_left  d=dest_data usw.
  316.     
  317.     move.a    r3,a
  318.     move.a    r1,c
  319.     sub.a    c,a
  320.     dec.a    a    ; dist= (source-adr)-1
  321.     move.a    #255,c
  322.     ble.a    a,c,.1b
  323.     bra    no_field
  324. .1b    
  325.     move.a    a,r1    ; jetzt ist distanz in r1.a
  326.     
  327.     move.b    r0,a
  328.     move.b    #5,c
  329.     bge.b    a,c,.1
  330.     bra    no_field
  331. .1    
  332.     move.b    #12,c
  333.     bge.b    a,c,.8
  334.             ;**** 5er - 11er Feld ****
  335.     
  336.     bsr    norm_out
  337.     
  338.     move.b    r0,a
  339.     sub.b    #4,a
  340.     move.b    #3-1,c
  341.     bsr    bitsout
  342.     
  343.     move.a    r1,a
  344.     move.b    #8-1,c
  345.     bsr    bitsout
  346.     
  347.     clr.a    c
  348.     move.b    r0,c
  349.     bra    end_field
  350.     
  351. .8            ; ****** 12er - 43er Feld ******
  352.     
  353.     bsr    norm_out
  354.     
  355.     bsr    bit0out
  356.     bsr    bit0out
  357.     bsr    bit0out
  358.     
  359.     move.b    r0,a
  360.     sub.b    #12,a
  361.     move.b    #5-1,c
  362.     bsr    bitsout
  363.     
  364.     move.a    r1,a
  365.     move.b    #8-1,c
  366.     bsr    bitsout
  367.     
  368.     clr.a    c
  369.     move.b    r0,c
  370.     
  371. end_field    ; in c.a zahl der nibbles im feld
  372.     
  373.     move.a    r4,a
  374.     sub.a    c,a
  375.     bcc    .1
  376.     bra.4    bad_arg_error
  377. .1    
  378.     move.a    a,r4    ; neue nibs_left
  379.     
  380.     move.a    r3,a
  381.     add.a    c,a
  382.     move.a    a,r3    ; neue adresse
  383.     move.ao    #last_norm,d0
  384.     move.a    a,(d0)
  385.     
  386.     move.a    r4,a
  387.     beq.a    a,0,compress_fini
  388.     
  389.     bra    nextnib
  390.  
  391. no_field    
  392.     move.a    r4,a
  393.     dec.a    a
  394.     bcc    .1
  395.     bra.4    bad_arg_error
  396. .1    
  397.     move.a    a,r4    ; neue nibs_left
  398.     
  399.     move.a    r3,a
  400.     inc.a    a
  401.     move.a    a,r3    ; neue adresse
  402.     
  403.     move.a    r4,a
  404.     beq.a    a,0,compress_fini
  405.     
  406.     bra    nextnib
  407.  
  408. compress_fini    
  409.     bsr    norm_out
  410. test1    
  411. .2    
  412.     clr.xs    c
  413.     beq.xs    c,d,.1
  414.     
  415.     bsr    bit0out
  416.     bra    .2
  417. .1    
  418.     bsr    bit0out
  419.     
  420.     move.ao    #dest_adr,d0
  421.     move.a    (d0),a
  422.     sub.a    #2,a    ; letztes "code-byte" ist leer
  423.     move.ao    #work_mem_adr,d0
  424.     move.a    (d0),c
  425.     sub.a    c,a    ; in a.a new_len
  426.     
  427.     bbc    #0,a,.4
  428.     inc.a    a
  429. .4    
  430.     move.ao    #new_len,d0
  431.     move.a    a,(d0)
  432.     
  433.     move.ao    #strlen_adr,d0
  434.     move.a    (d0),c
  435.     move.a    c,d0
  436.     move.a    a,c
  437.     sub.a    #5,c
  438.     move.a    c,(d0)
  439.     
  440.     move.ao    #old_len,d0
  441.     move.a    (d0),c
  442.     bge.a    a,c,.3
  443.     
  444.     rtncc
  445. .3    
  446.     rtnsc
  447.  
  448. norm_out    
  449.     move.a    r3,a
  450.     move.ao    #last_norm,d0
  451.     move.a    (d0),c
  452.     sub.a    c,a    ; in a.a zahl der norm-bytes
  453.     move.a    a,r2    ; in r2.a auch
  454. cont_norm    
  455.     move.a    r2,a
  456.     bne.a    a,0,.1
  457.             ; ******* 0 ********
  458.     bsr    bit0out
  459.     
  460.     rtn
  461. .1    
  462.     move.a    #31,c
  463.     bgt.a    a,c,.2
  464.             ; **** 1 - 31 ****
  465.     bsr    bit1out
  466.     
  467.     move.a    r2,a
  468.     move.b    #5-1,c
  469.     bsr    bitsout
  470.     
  471.     move.a    r2,c
  472.     bra    copy_norm
  473. .2    
  474.     move.a    #94,c
  475.     bgt.a    a,c,.4
  476.             ; *** 32 - 94 ****
  477.     bsr    bit1out
  478.     bsr    bit0out
  479.     bsr    bit0out
  480.     bsr    bit0out
  481.     bsr    bit0out
  482.     bsr    bit0out
  483.     
  484.     move.a    r2,a
  485.     sub.a    #16,a    ; -31
  486.     sub.a    #15,a
  487.     move.b    #6-1,c
  488.     bsr    bitsout
  489.     
  490.     move.a    r2,c
  491.     bra    copy_norm
  492.     
  493. .4            ; *** 95 und weiter ***
  494.     move.a    #%100000000000,a
  495.     move.b    #12-1,c
  496.     bsr    bitsout
  497.     
  498.     move.a    r2,a
  499.     move.a    #95,c
  500.     sub.a    c,a
  501.     move.a    a,r2
  502.     
  503.     bsr    copy_norm
  504.     bra    cont_norm
  505.  
  506. bit1out    
  507.     dec.xs    d
  508.     bcs    .1
  509.     add.b    d,d
  510.     inc.b    d
  511.     rtn
  512. .1    
  513.     move.ao    #last_code_adr,d0
  514.     move.a    (d0),c
  515.     move.a    c,d1
  516.     move.b    d,c
  517.     move.b    c,(d1)
  518.     
  519.     move.ao    #dest_adr,d1
  520.     move.a    (d1),c
  521.     move.a    c,(d0)
  522.     add.a    #2,c
  523.     move.a    c,(d1)
  524.     
  525.     move.ao    #mem_left,d0
  526.     move.a    (d0),c
  527.     sub.a    #2,c
  528.     bcc    .2
  529.     bra.4    mem_error
  530. .2    
  531.     move.a    c,(d0)
  532.     move.x    #$701,c
  533.     move.x    c,d
  534.     rtn
  535.  
  536. bit0out    
  537.     dec.xs    d
  538.     bcs    .1
  539.     add.b    d,d
  540.     rtn
  541. .1    
  542.     move.ao    #last_code_adr,d0
  543.     move.a    (d0),c
  544.     move.a    c,d1
  545.     move.b    d,c
  546.     move.b    c,(d1)
  547.     
  548.     move.ao    #dest_adr,d1
  549.     move.a    (d1),c
  550.     move.a    c,(d0)
  551.     add.a    #2,c
  552.     move.a    c,(d1)
  553.     
  554.     move.ao    #mem_left,d0
  555.     move.a    (d0),c
  556.     sub.a    #2,c
  557.     bcc    .2
  558.     bra.4    mem_error
  559. .2    
  560.     move.a    c,(d0)
  561.     move.x    #$700,c
  562.     move.x    c,d
  563.     rtn
  564.  
  565. bitsout    ; in a.a wert, in c.b zahl der bits -1
  566.     
  567.     move.b    c,b
  568.     move.b    #19,c
  569.     sub.b    b,c
  570.     
  571.     dec.b    c
  572.     bcs    .11
  573. .12    
  574.     add.a    a,a
  575.     dec.b    c
  576.     bcc    .12
  577. .11    
  578.     
  579. .15    
  580.     dec.xs    d
  581.     bcc    .14
  582.     
  583.     move.ao    #last_code_adr,d0
  584.     move.a    (d0),c
  585.     move.a    c,d1
  586.     move.b    d,c
  587.     move.b    c,(d1)
  588.     
  589.     move.ao    #dest_adr,d1
  590.     move.a    (d1),c
  591.     move.a    c,(d0)
  592.     add.a    #2,c
  593.     move.a    c,(d1)
  594.     
  595.     move.ao    #mem_left,d0
  596.     move.a    (d0),c
  597.     sub.a    #2,c
  598.     bcc    .1
  599.     bra.4    mem_error
  600. .1    
  601.     move.a    c,(d0)
  602.     move.x    #$700,c
  603.     move.x    c,d
  604. .14    
  605.     add.b    d,d
  606.     add.a    a,a
  607.     bcc    .14b
  608.     inc.b    d
  609. .14b    
  610.     
  611.     dec.b    b
  612.     bcc    .15
  613.     
  614.     rtn
  615.  
  616. copy_norm    ; in c.a laenge
  617.     
  618.     move.a    #$10b,d0
  619.     move.1    c,(d0)
  620.     
  621.     move.ao    #last_norm,d0
  622.     move.a    (d0),a
  623.     move.a    a,d1
  624.     add.a    c,a
  625.     move.a    a,(d0)
  626.     
  627.     move.ao    #mem_left,d0
  628.     move.a    (d0),a
  629.     sub.a    c,a
  630.     bcc    .1
  631.     bra.4    mem_error
  632. .1    
  633.     move.a    a,(d0)
  634.     
  635.     move.ao    #dest_adr,d0
  636.     move.a    (d0),a
  637.     move.a    a,b
  638.     add.a    c,a
  639.     move.a    a,(d0)
  640.     
  641.     move.a    b,a
  642.     move.a    a,d0
  643.     
  644.     dec.a    c
  645. .2    
  646.     move.xs    (d1),a
  647.     move.xs    a,(d0)
  648.     add.a    #1,d0
  649.     add.a    #1,d1
  650.     dec.a    c
  651.     bcc    .2
  652.     
  653.     rtn
  654.  
  655. mem_error    
  656.     move.a    #$4fbb,a
  657.     bra    err_exit
  658.  
  659. bad_arg_error    
  660.     move.a    #$18ca7,a
  661.     
  662. err_exit    ; in a.a adresse
  663.     pop
  664.     pop
  665.     pop
  666.     pop
  667.     pop
  668.     pop
  669.     pop
  670.     pop
  671.     
  672.     move.a    a,c
  673.     push
  674.     
  675.     move.ao    #work_mem_adr,d0
  676.     move.a    (d0),c
  677.     move.a    c,d1
  678.     move.a    #$02dcc,c
  679.     move.a    c,(d1)
  680.     add.a    #5,d1
  681.     
  682.     move.ao    #work_mem_len,d0
  683.     move.a    (d0),c
  684.     sub.a    #5,c
  685.     move.a    c,(d1)
  686.     
  687.     move.a    #$100,d0
  688.     move.1    (d0),c
  689.     bset    #3,c
  690.     move.1    c,(d0)
  691.     bset    #15,st
  692.     inton
  693.     
  694.     bclr    #$a,st
  695.     jsr    restore_regs
  696.     rtn
  697.  
  698.     
  699.     ; Variablen
  700. stack_ptr    dcr.5    0
  701. work_mem_adr    dcr.5    0
  702. work_mem_len    dcr.5    0
  703. old_obj_adr    dcr.5    0
  704. new_obj_adr    dcr.5    0
  705. old_len    dcr.5    0
  706. new_len    dcr.5    0
  707. strlen_adr    dcr.5    0
  708. mem_left    dcr.5    0
  709. dest_adr    dcr.5    0
  710. last_norm    dcr.5    0
  711. last_code_adr    dcr.5    0
  712.     
  713. pgmend    
  714.     include    "src:rerelpgm.a"
  715.     
  716.     rpl    Drop    ; laenge weg
  717.     
  718.     rpl    $0312b
  719.  
  720.     include    src:class.sym
  721.  
  722.