' IMG_PACK.LST
' Packing a monochrome picture into an IMG graphic
' -------------------------------------------
' Load and display picture
a$=SPACE$(32034)
BLOAD "KARIN.PI3",VARPTR(a$)
a$=RIGHT$(a$,32000)
SPUT a$
'
' Width and height of section to be packed
w%=640
h%=400
' Origin and address
GET x%,y%,x%+w%-1,y%+h%-1,s$
s%=VARPTR(s$)+6
'
' if picture width uneven, then erase last byte
xb%=(w%+7) DIV 8
xxb%=((w%+15) DIV 16)*2
IF xxb%>xb%
  dh%=s%
  FOR m%=y% TO (y%+h%-1)
    BMOVE h%,dh%,xb%
    ADD s%,xxb%
    ADD dh%,xb%
  NEXT m%
ENDIF
s%=VARPTR(s$)+6
'
' Reserve memory space for destination IMG graphic
d$=SPACE$(32700)
' Address
d%=VARPTR(d$)
'
ALERT 2,"Pack graphic |in GFA BASIC|or GFA ASSEMBLER?",1,"Basic|Ass.",question%
t=TIMER
'
' GFA BASIC
IF question%=1
  ' M%,Y%=line counter
  m%=0
  y%=0
  '
  ' Z%=current length of packed picture
  z%=0
  '
  ' Write header
  a$=MKI$(1)+MKI$(8)+MKI$(1)+MKI$(2)+MKI$(372)+MKI$(372)+MKI$(w%)+MKI$(h%)
  BMOVE VARPTR(a$),d%+z%,16
  ADD z%,16
  '
  ' A$=the current first line (line to be packed)
  ' b$=2.-nth line
  a$=STRING$(xb%,0)
  '
  REPEAT
    '
    b$=STRING$(xb%,0)
    '
    ' Compare lines
    BMOVE s%+y%*xb%,VARPTR(a$),xb%
    REPEAT
      INC y%
      BMOVE s%+y%*xb%,VARPTR(b$),xb%
    UNTIL a$<>b$ OR y%=h% OR y%>=m%+255
    '
    ' if several lines, then line repeat header
    ' b$=now: line repeat header
    IF y%>m%+1
      b$=MKI$(0)+CHR$(255)+CHR$(y%-m%)
      BMOVE VARPTR(b$),d%+z%,4
      ADD z%,4
    ENDIF
    '
    ' now analyse line
    ' b$= now: packed line
    CLR b$
    '
    ' Start%=last starting position, by testing start%
    ' it is possible to find out if there is a still unpacked section
    ' between two packed ones
    start%=1
    '
    ' Mb%=Byte counter from 1 to Xb%-2
    '
    ' Zb%=Auxiliary byte counter, Zb% is incremented if a possibly packable section
    ' has been found. If it is actually packable, then
    ' Mb%=Zb%-1, i.e. the byte counter proper skips the
    ' packed section
    '
    FOR mb%=1 TO xb%-2
      a%=CVI(MID$(a$,mb%,2))
      '
      ' white
      IF a%=0
        zb%=mb%+1
        REPEAT
          INC zb%
        UNTIL MID$(a$,zb%,1)<>CHR$(0)
        ' if three or more zero bytes(0)
        IF zb%>mb%+2
          IF mb%>start%
            @unpacked(start%,mb%-1)
          ENDIF
          nr%=zb%-mb%
          ' pack max. 127 bytes
          REPEAT
            b$=b$+CHR$(MIN(127,nr%))
            SUB nr%,127
          UNTIL nr%<=0
          mb%=zb%-1
          start%=zb%
        ENDIF
      ENDIF
      '
      ' black
      IF a%=65535
        zb%=mb%+1
        REPEAT
          INC zb%
        UNTIL MID$(a$,zb%,1)<>CHR$(255)
        ' if 3 or more full bytes(255)
        IF zb%>mb%+2
          IF mb%>start%
            @unpacked(start%,mb%-1)
          ENDIF
          nr%=zb%-mb%
          ' pack max. 127 bytes
          REPEAT
            b$=b$+CHR$(MIN(127,nr%)+128)
            SUB nr%,127
          UNTIL nr%<=0
          mb%=zb%-1
          start%=zb%
        ENDIF
      ENDIF
      '
      ' Pattern
      IF a%<>0 AND a%<>65535
        zb%=mb%
        REPEAT
          ADD zb%,2
        UNTIL CVI(MID$(a$,zb%,2))<>a%
        ' if 3 or more patterns (words)
        IF zb%>mb%+4
          IF mb%>start%
            @unpacked(start%,mb%-1)
          ENDIF
          b$=b$+CHR$(0)+CHR$((zb%-mb%)/2)+MID$(a$,mb%,2)
          mb%=zb%-1
          start%=zb%
        ENDIF
      ENDIF
    NEXT mb%
    '
    ' unpacked bytes at end of line
    IF start%<=xb%
      @unpacked(start%,xb%)
    ENDIF
    BMOVE VARPTR(b$),d%+z%,LEN(b$)
    ADD z%,LEN(b$)
    m%=y%
  UNTIL m%>=h%
ENDIF
'
' GFA ASSEMBLER
IF question%=2
  INLINE ass_in%,958
  ' Calling assembler program, with
  ' s% and d% being the addresses of the graphics data
  ' w% and h% being the dimensions of the source picture in pixels
  ' Return value z%=Length of packed file
  z%=C:ass_in%(1,L:d%,L:s%,w%,h%)
  d$=LEFT$(d$,z%)
ENDIF
'
tt=(TIMER-t)/200
t$=STR$(tt)
IF question%=1
  ALERT 1,"Packing graphic |in GFA BASIC takes|"+t$+" seconds.",1," OK ",d%
ELSE
  ALERT 1,"Packing graphic |in GFA ASSEMBLER takes|"+t$+" seconds.",1," OK ",d%
ENDIF
'
z$=STR$(z%)
ALERT 2,"Save IMG graphic? |It has a length of |"+z$+" bytes.",1," OK |NO",d%
IF d%=1
  BSAVE "KARIN.IMG",VARPTR(d$),z%
ENDIF
'
EDIT
'
PROCEDURE unpacked(start%,fin%)
  nr%=fin%-start%+1
  ' max. 255 Bytes unpacked
  REPEAT
    b$=b$+CHR$(128)+CHR$(MIN(nr%,255))+MID$(a$,start%,MIN(nr%,255))
    SUB nr%,255
    ADD start%,255
  UNTIL nr%<=0
RETURN