;Dizpack, by SAM style
;обязательно круглые
frqtab    EQU #6000
symtab    EQU #6200
    ORG #6300
;Пример использования упаковщика и распаковщика
    LD HL,text    ;HL - откуда паковать
    LD DE,bufa    ;DE - куда паковать
    LD BC,txtlen    ;BC - сколько байт
    CALL PACK    ;пакуем
    LD DE,bufa
    AND A
    SBC HL,DE    ;HL - длинна упакованного файла
    LD HL,bufa
    CALL UNPACK    ;инициализация распаковки
        ;самой распаковки здесь не происходит.
;Проверка правильности распаковки (была сделана для тестирования распаковки - в прин­ципе теперь не нужна)
    LD DE,text
tst_1    CALL GETBYTE    ;вынимаем байт из потока
    RET NC
    LD C,A
    LD A,(DE)
    CP C
    JR NZ,err
    INC DE
    JR tst_1
err    LD A,2
    OUT (254),A
    RET
;---------------------------
;Проверка сигнатуры
TESTSIG    LD E,(HL)
    INC HL
    LD D,(HL)
    INC HL
    EX DE,HL
    AND A
    SBC HL,BC
    EX DE,HL
    LD A,D
    OR E
    RET Z
    SCF
    RET
;-------------
;UNPACK - инициализация распаковки
;распаковки не происходит!
;Вход: HL = адрес упакованного блока
;Выход: CY=1 (C) - не поддерживаемый формат ;CY=0 (NC) - можно распаковывать
UNPACK    LD BC,«DZ»
    CALL TESTSIG
    RET C
    LD BC,#0031
    CALL TESTSIG
    RET C
    LD C,(HL)
    INC HL
    LD B,(HL)
    INC HL
    LD (GETBYTE+1),BC
    LD A,(HL)
    INC HL
    LD (unp_ta+1),HL
    ADD A,L
    LD L,A
    ADC A,H
    SUB L
    LD H,A
    LD (unp_ad+1),HL
    LD A,#A7
    LD (GETHALF),A    ;(код команды AND A)
    AND A
    RET
;GETBYTE - выемка байта из потока.
;Вход: ничего, всё инициализируется через UNPACK.
;Выход: CY=0 (NC) - уже нечего вынимать;CY=1 (C) вынут байт A=его код.
GETBYTE    LD BC,0
    LD A,B
    OR C
    RET Z
    DEC BC
    LD (GETBYTE+1),BC
unp_ad    LD HL,0
    LD C,-15
gbt_1    LD A,C
    ADD A,15
    LD C,A
    CALL GETHALF
    CP 15
    JR Z,gbt_1
    ADD A,C
    LD (unp_ad+1),HL
unp_ta    LD HL,0
    LD C,A
    LD B,0
    ADD HL,BC
    LD A,(HL)
    SCF
    RET
GETHALF    AND A
    LD A,(HL)
    JR C,ghl_1
    RRCA
    RRCA
    RRCA
    RRCA
ghl_1    AND 15
    EXA
    LD A,(GETHALF)
    XOR #90
    LD (GETHALF),A
    CP #A7
    JR NZ,ghl_2
    INC HL
ghl_2    EXA
    RET
;-----------------------
;Вход: HL - откуда паковать, DE - куда, BC - сколько байт
;Выход: HL - следующий адрес за упакованным блоком
PACK    EX DE,HL
    LD (HL), «D»
    INC HL
    LD (HL), «Z»
    INC HL
    LD (HL), «1»
    INC HL
    LD (HL),#00
    INC HL
    LD (HL),C
    INC HL
    LD (HL),B
    INC HL
    EX DE,HL
    PUSH BC
    PUSH HL
    PUSH DE
    CALL MAKETAB
    LD HL,frqtab
    LD E,0
pk_1    INC H
    LD A,(HL)
    DEC H
    OR (HL)
    JR Z,pk_2
    INC E
    INC L
    JR NZ,pk_1
pk_2    LD A,E
    POP DE
    LD (DE),A
    INC DE
    LD C,A
    LD B,0
    AND A
    JR NZ,pk_3
    INC B
pk_3    LD HL,symtab
    LDIR
    EX DE,HL
    POP DE
    POP BC    ;DE:FROM;HL:TO;BC:COUNT
    XOR A
    EXA    ;Z:1ST HALFBYTE, NZ:2ND
pk_35    LD A,(DE)
    PUSH HL
    LD HL,symtab
pk_4    CP (HL)
    JR Z,pk_5
    INC L
    JR NZ,pk_4
pk_5    LD A,L
    POP HL
pk_6    CP 15
    JR C,pk_7
    SUB 15
    PUSH AF
    LD A,15
    CALL PUT_IN
    POP AF
    JR pk_6
pk_7    CALL PUT_IN
    INC DE
    DEC BC
    LD A,B
    OR C
    JR NZ,pk_35
    EXA
    AND A
    RET Z
    EXA
    LD A,15
PUT_IN    RLD
    EXA
    XOR 2
    JR NZ,pin_1
    INC HL
pin_1    EXA
    RET
;------------------
;Вход: HL: адрес текста, BC: длина
;Выход: frqtab и symtab - упорядоченная таблица частот и символов.
;Таблицы frqtab и symtab обязательно должны идти друг за другом.
MAKETAB    PUSH HL
    LD HL,frqtab
    XOR A
mtb_1    LD (HL),A
    INC H
    LD (HL),A
    DEC H
    INC L
    JR NZ,mtb_1
    POP DE
    LD HL,frqtab
mtb_2    LD A,(DE)
    LD L,A
    INC (HL)
    JR NZ,mtb_3
    INC H
    INC (HL)
    DEC H
mtb_3    INC DE
    DEC BC
    LD A,B
    OR C
    JR NZ,mtb_2
    LD HL,symtab
mtb_4    LD (HL),L
    INC L
    JR NZ,mtb_4
    LD HL,frqtab
mtb_5    AND A
    EXA
    LD B,255
    LD L,0
mtb_6    PUSH HL
    LD E,(HL)
    INC H
    LD D,(HL)
    INC L
    LD A,(HL)
    DEC H
    LD L,(HL)
    LD H,A
    EX DE,HL
    AND A
    SBC HL,DE
    POP HL
    JR NC,mtb_7
    CALL SWAP
    INC H
    CALL SWAP
    INC H
    CALL SWAP
    DEC H
    DEC H
    EXA
    SCF
    EXA
mtb_7    INC L
    DJNZ mtb_6
    EXA
    JR C,mtb_5
    RET
SWAP    LD C,(HL)
    INC L
    LD A,(HL)
    LD (HL),C
    DEC L
    LD (HL),A
    RET
text    INCBIN «main_txt»    ;подгружаем текст, который нужно упаковать
txtlen    EQU $-text
bufa    EQU $    ;буфер для упаковки