'--------------------------------------------------------------------------
'JPEG loader by Antoni Gual   12/1999    antonigual@eic.ictnet.es
'commented version            10/2003
'Ported to FB                  5/2005
'Adapted to FB0.17 by Luke Landriaut 11/2006
'removed multikey,floating point,unneeded byref parameters 
'--------------------------------------------------------------------------
' to do 
' make it a library 
' better header parsing
' add support for progresive jpeg 
' make it smaller
'SUB DECLARES----------------------------------------------------------------
#include "jpeg4gfxlib.bi"


'DEFINT A-Z
Const dc = 0, AC = 1              'indexs to huffman and quant tables


'JPEG markers
'start of frames
Const mk_sof0 = &HFFC0&
Const mk_sof1 = &HFFC1&, mk_sof2 = &HFFC2&, mk_sof3 = &HFFC3&
Const mk_sof5 = &HFFC5&, mk_sof6 = &HFFC6&, mk_sof7 = &HFFC7&
Const mk_rsrvd = &HFFC8&
Const mk_sof9 = &HFFC9&, mk_sofa = &HFFCA&, mk_sofb = &HFFCB&
Const mk_sofd = &HFFCD&, mk_sofe = &HFFCE&, mk_soff = &HFFCF&

'tables and miscelaneous
Const mk_tblhuff = &HFFC4&, mk_tblari = &HFFCC&
Const mk_tblquan = &HFFDB&, mk_tbldri = &HFFDD&
Const mk_com = &HFFFE&
Const mk_app0 = &HFFE0&, mk_app1 = &HFFE1&, mk_app2 = &HFFE2, mk_app3 = &HFFE3
Const mk_app4 = &HFFE4, mk_app5 = &HFFE5, mk_app6 = &HFFE6, mk_app7 = &HFFE7
Const mk_app8 = &HFFE8, mk_app9 = &HFFE9, mk_appa = &HFFEA, mk_appb = &HFFEB
Const mk_appc = &HFFEB, mk_appd = &HFFED, mk_appe = &HFFEE, mk_appf = &HFFEF&

'restarts
Const mk_rst0 = &HFFD0&, mk_rst1 = &HFFD1, mk_rst2 = &HFFD2, mk_rst3 = &HFFD3
Const mk_rst4 = &HFFD4, mk_rst5 = &HFFD5, mk_rst6 = &HFFD6, mk_rst7 = &HFFD7&

'headers
Const mk_soi = &HFFD8&, mk_eoi = &HFFD9&
Const mk_SOS = &HFFDA&, mk_dnl = &HFFDC&
Const mk_dhp = &HFFDF6, mk_exp = &HFFDF&
Const mk_dri = &HFFDD&
'reserved
Const mk_jpg0 = &HFFF0, mk_jpg1 = &HFFF1, mk_jpg2 = &HFFF2, mk_jpg3 = &HFFF3
Const mk_jpg4 = &HFFF4, mk_jpg5 = &HFFF5, mk_jpg6 = &HFFF6, mk_jpg7 = &HFFF7
Const mk_jpg8 = &HFFF8, mk_jpg9 = &HFFF9, mk_jpga = &HFFFA, mk_jpgb = &HFFFB
Const mk_jpgc = &HFFFB, mk_jpgd = &HFFFD

#define IS_A_SOF mk_sof0 to mk_sof3,mk_sof5 to mk_sof7,mk_sof9 to mk_sofb,mk_sofd to mk_soff
#define IS_A_APPn mk_app0 to mk_appF


'stores  the JPEG image parmeters
Type JpegType
  jfifmajor     As Integer   'version
  jfifMinor     As Integer
  densunits     As Integer        'density units and values (not used)
  Xdens         As Integer
  ydens         As Integer
  ThWidth       As Integer   'thumbnail size
  Theigth       As Integer
  pendbytes     As Integer 
  rows          As Integer      'jpeg height
  cols          As Integer      'jpeg width
  samplesyx     As Integer      'sampling ratios
  samplesyy     As Integer      'sampling ratios
  samplescbcrx  As Integer
  samplescbcry  As Integer
  qty           As Integer      'number of quantization tables
  qtcbr         As Integer
  HDCTY         As Integer      'number of huffman tables (DC and AC)
  HDCTCBR       As Integer
  HaCTY         As Integer
  HaCTcbr       As Integer
  numcomp       As Integer      'number of components
  restart       As Integer      'blocks between restart marks
  size          As Long         'FILE SIZE
End Type

Type vesatype
  xres          As Integer
  yres          As Integer
  depth         As Integer
End Type

'------------------------------------------------------------------------


'SHARED VARIABLES. 

'simple vars
Dim Shared As Integer jfile                     'file vars

Dim Shared As Uinteger jpegmem
Dim Shared As Ubyte Ptr jpegmem_ptr
Dim Shared As Integer buf2_ptr
Dim Shared As Uinteger buf2           'pointer to Huffman decoder secondary buffer

Dim Shared pbuff As Ubyte Ptr: Const bsize=1023
Redim  Shared buff(0) As Ubyte

'UDT


Dim Shared vport As vesatype
Dim Shared As Integer inscan
Dim Shared jpeg As JpegType

'JPEG tables

' quantization
Redim Shared As Integer quant(0, 0)
'huffman decoding
Dim Shared huffstart(15) As Integer
Const hufftblsize=761
Redim Shared As Integer Hufftree(0) 'AS Huffmantreeentry

'dim shared buffer as any ptr

Dim Shared As Integer zz(0 To 63) => {_
0,  1,  8, 16,  9,  2,  3, 10,_
17, 24, 32, 25, 18, 11,  4,  5,_
12, 19, 26, 33, 40, 48, 41, 34,_
27, 20, 13,  6,  7, 14, 21, 28,_
35, 42, 49, 56, 57, 50, 43, 36,_
29, 22, 15, 23, 30, 37, 44, 51,_
58, 59, 52, 45, 38, 31, 39, 46,_
53, 60, 61, 54, 47, 55, 62, 63}         


'dim shared imgcomment
'dim shared marker, email

'used in huffman decoder
Dim Shared As Uinteger Ptr p1stbit,pmaskbits
Dim Shared As Integer indx,mxind


'START------------------------------------------------------------------
Private Function GFxlibOn As Integer
  If Screenptr =0 Then Return err_nogfxlib
  Screeninfo vport.xres,vport.yres,vport.depth
  If vport.depth<15 Then Return err_palmode
End Function
'
'---------------------------------------------------------------------------
Function JPEGGetByte As Integer
  'used when decoding the headers (not critical), inscan turns on an off
  'detection of pairs FF00 and it's conversion of FF
  Static As Ubyte lb,b
  
  lb=b
  If jfile <> 0 Then
    Get #jfile,,b
  Else
    b = jpegmem_ptr[ jpegmem ]
    jpegmem += 1
  End If
  If inscan Then
    If lb=255 And b=0 Then
      If jfile <> 0 Then
        Get #jfile,,b
      Else
        b = jpegmem_ptr[ jpegmem ]
        jpegmem += 1
      End If
    End If
  End If
  jpeg.pendbytes -=1
  Function=lb
  
End Function
'
'----------------------------------------------------------------------------
Function GetByteBuffered As Integer
  'using in decoding image scans (a speed critical part)
  'detection of pairs FF00 and it's conversion of FF is made when bufferis filled  
  Static As Integer i,j
  Dim As Integer k
  If indx>mxind Then
    If jfile <> 0 Then
      Get #jfile,,buff()
    Else
      For k = Lbound(buff) To Ubound(buff)
        buff(k) = jpegmem_ptr[ jpegmem ]
        jpegmem += 1
      Next k
    End If
    indx=0
    mxind=bsize
    If pbuff[mxind]=&hff Then
      mxind-=1
      If jfile <> 0 Then
        Seek jfile,Seek(jfile)-1
      Else
        jpegmem -= 1
      End If
    End If
    i=0 
    
    Do 
      If pbuff[i]=&hFF Then
        If pbuff[i+1]=0 Then 
          For j=i+1 To mxind-1
            pbuff[j]=pbuff[j+1]
          Next
          mxind-=1
        End If
      End If
      i+=1 
    Loop Until i>=mxind
    
  End If  
  Function=pbuff[indx]:indx+=1
End Function

'
'---------------------------------------------------------------------------
Function JPEGGetHuff (posini As Integer) As Integer
  'Called by JpegGet8x8
  'Gets bits from file until they match a Huffman table entry. When match
  ' found it returns the associated code.
  'The table is in the form of a binary tree
  Dim As Integer h_ptr =Any ,i = Any
  'shared Huftree(),buf2,buf2_ptr
  'init pointer to tree array
  h_ptr = huffstart(posini)
  
  'gather bits until we match a huffman pattern and read Huff code from tree
  Do
    'prepare mask the next bit in input buffer    
    If buf2_ptr=0 Then buf2=getbytebuffered:buf2_ptr=8
    buf2_ptr -=1
    i=1 Shl (buf2_ptr)
    
    'select side depending of next bit
    If buf2 And i Then h_ptr+=1
    'read value in that side
    h_ptr = Hufftree(h_ptr)
    
    'if h_ptr<1 we have reached a tree leaf
  Loop Until h_ptr<1
  'return the code we read in the leaf 
  Function = -h_ptr
End Function
'
'---------------------------------------------------------------------------
Function JPEGGetNBits (nbits As Integer) As Integer
  'Called by JpegGet8x8
  'Fetches nbits bits from the file, if first bit off it performs the "negation"
  'required by Jpeg specs.
  '#define bit3(x) (1 shl (x))-1
  Dim As Integer GetNBits =Any
  'fillbitbuffer 
  While buf2_ptr < nbits
    buf2 = (buf2 Shl 8) Or  GetBytebuffered  
    buf2_ptr += 8
  Wend
  
  'get n bits.
  buf2_ptr = buf2_ptr - nbits
  GetNBits = buf2 Shr buf2_ptr 
  
  'clip left ,then if msb is 0 negate and make negative (jpeg spec)
  If GetNBits And p1stbit[nbits] Then 
    Function = GetNBits And pmaskbits[nbits] 
  Else 
    Function = -(Not GetNBits And pmaskbits[nbits])
  End If
End Function


'---------------------------------------------------------------------------
Sub JPEGGet8x8 (vector As Integer Ptr, comp As Integer, Byref dcCoef As Integer) 
  ' Reads enough bits from JPEG file so Huffman decoder can build an 8X8 block
  ' Then reorders block based on zigzafg table, dequantizaes and IDCT
  ' transforms the block so the returned block is an ordered 8x8 Y, Cb or Cr
  ' component block
  '
  ' Decoding of progressive jpegs would need saving all 8x8 blocks at the output
  '  of the huffman decoder so they could be updated with the data from several
  '  scans before zigzag-dequant-idct-display-ing them
  
  ' vector Returns a block
  ' comp tells us if it's a luminance(Y) or a chrominance component, as differnt
  '  dequant-huffman tables must be used
  ' In dccoef we receive the dc component  from last block and return
  '  the dc component of this block (dc component is coded incrementally)
  
  
  'HUFFMAN DECODER-----------------------------------------------------------
  ' Reads enough bits from JPEG file to build an 8X8 block and de-zigzags it
  ' A block's coefficient is encoded as two variable length values:
  '   an entry to a huffman table and the actual value.
  ' The entry to Huff table indexes a code made of 2 nibbles
  '   codes 0 and 3270 have special meanings; for the rest
  '   high nibble is an offset from the present position in the block
  '   low nibble is nr of bits to retrieve for the value
  '--------------------------------------------------------------------------
  'select correct  Huffman and dequant tables
  Dim As Integer tx=Any,dekode=Any,nbits=Any,k=Any,thebits=Any
  'dim p as any ptr=any
  
  Select Case As Const comp
  Case 1 
    tx = 0
  Case 2 
    tx = 2
    
  Case Else
  
  End Select

  'preset the complete vector to zeros
  For k=0 To 63:vector[k]=0:Next 
  
  'The DC coefficient is incremental
  nbits = JPEGGetHuff(tx)
  dcCoef += JPEGGetNBits(nbits)
  vector[0] = dcCoef
  
  'AC Coefficients are calculated from scratch
  k = 1
  Do
    dekode = JPEGGetHuff(tx + 1)
    Select Case As Const dekode And &hff
    Case 0 'EndOfBlock.Rest of vector is already padded with 0's 
      
      '    print #1, dekode, "eob"
      Exit Do
    Case 240 'ZeroRunLength encountered  240=15*16+0
      '   print #1, dekode, "zrl" 
      k = k + 16
    Case Else 'a true coefficient follows
      'first nibble: index increment
      k += dekode Shr 4
      'second nibble:nr of bits to fetch
      vector[zz(k)] =JPEGGetNBits(dekode And 15) 
      k+=  1
    End Select
  Loop Until k > 63
End Sub
'
'----------------------------------------------------------------------------
Sub IDCT(vector As Integer Ptr,comp As Integer)
  
  'Dequantization and IDCT routines-----------------------------------------------
  
  'The true IDCT is as follows:
  'The 4 dimensional IDCT coefficients matrix
  'DIM dct!(X,Y,U,V)
  'FOR x = 0 TO 7           'Initialize our cosine table
  ' FOR y = 0 TO 7
  '    FOR u = 0 TO 7
  '     FOR v = 0 TO 7
  '        t! = COS((2 * x + 1) * u * .1963495) * COS((2 * y + 1) * v * .1963495)
  '        IF u = 0 THEN t! = t! * .707107
  '        IF v = 0 THEN t! = t! * .707107
  '        dct!(x, y, u, v) = t!
  '     NEXT v
  '    NEXT u
  ' NEXT y
  'NEXT x
  '
  'IDCT calculation for a given vector: output in array2
  'FOR x = 0 TO 7
  '    FOR y = 0 TO 7
  '        sum! = 0
  '        FOR v = 0 TO 7
  '            FOR u = 0 TO 7
  '                temp! = vector(u, v)
  '                IF temp! THEN temp! = temp! * dct!(x, y, u, v)
  '                sum! = sum! + temp!
  '            NEXT u
  '        NEXT v
  '        array2!(x, y) = sum!+128!
  '   NEXT y
  'NEXT x
  '
  'The actual method used there is ported from the C source examples by the
  'independant JPEG group.It reduces greatly the number of operations needed 
  
  'temporals for the IDCT routines
  Dim z1 As Long, z2 As Long, z3 As Long, z4 As Long, z5 As Long
  Dim z10 As Long, z11 As Long, z12 As Long, z13 As Long
  Dim tmp0 As Long, tmp1 As Long, tmp2 As Long, tmp3 As Long
  Dim tmp10 As Long, tmp11 As Long, tmp12 As Long, tmp13 As Long
  Dim As Integer u,v,quantnum
  
  Dim As Integer Ptr ptr1,pqnt
  
  'Inverse Discrete Cosinus Transform & dequantization using fixed point
  'Loeffler,Ligtenberg and Moschytz algorythm  
  
  #define descale12(a) ((a)+(1 Shl 11)) Shr 12
  #define descale17(a) ((a)+(1 Shl 16)) Shr 17 
  
  Const fix029 = 2446&
  Const FIX039 = -3196&
  Const FIX054 = 4433&
  Const FIX076 = 6270&
  Const FIX089 = -7373&
  Const FIX117 = 9633&
  Const fix150 = 12299&
  Const FIX184 = -15137&
  Const FIX196 = -16069&
  Const fix205 = 16819&
  Const FIX256 = -20995&
  Const fix307 = 25172&
  
  Const idctw=8
  
  Select Case comp
  Case 1 
    quantnum = jpeg.qty 
  Case 2 
    quantnum = jpeg.qtcbr
  End Select
  
  'row calc
  pqnt=@quant(quantnum,0)
  
  ptr1=vector
  'print pqnt
  'print ptr1
  
  For u = 0 To 7
    'if all row zeros, short circuit row calc
    If (ptr1[idctw*1] Or ptr1[idctw*2] Or ptr1[idctw*3] Or ptr1[idctw*4] Or ptr1[idctw*5] _
    Or ptr1[idctw*6] Or ptr1[idctw*7]) = 0 Then
    tmp0 = ptr1[idctw*0] * pqnt[idctw*0] Shl 1
    ptr1[idctw*0] = tmp0
    ptr1[idctw*1] = tmp0
    ptr1[idctw*2] = tmp0
    ptr1[idctw*3] = tmp0
    ptr1[idctw*4] = tmp0
    ptr1[idctw*5] = tmp0
    ptr1[idctw*6] = tmp0
    ptr1[idctw*7] = tmp0
  Else
    z2 = ptr1[idctw*2] * pqnt[idctw*2]
    z3 = ptr1[idctw*6] * pqnt[idctw*6]
    z1 = (z2 + z3) * FIX054
    tmp2 = z1 + (z3 * FIX184)
    tmp3 = z1 + (z2 * FIX076)
    z2 = ptr1[idctw*0] * pqnt[idctw*0]
    z3 = ptr1[idctw*4] * pqnt[idctw*4]
    tmp0 =  (z2 + z3) Shl 13
    tmp1 =  (z2 - z3) Shl 13
    tmp10 = tmp0 + tmp3
    tmp13 = tmp0 - tmp3
    tmp11 = tmp1 + tmp2
    tmp12 = tmp1 - tmp2
    tmp0 = ptr1[idctw*7] * pqnt[idctw*7]
    tmp1 = ptr1[idctw*5] * pqnt[idctw*5]
    tmp2 = ptr1[idctw*3] * pqnt[idctw*3]
    tmp3 = ptr1[idctw*1] * pqnt[idctw*1]
    z1 = tmp0 + tmp3
    z2 = tmp1 + tmp2
    z3 = tmp0 + tmp2
    z4 = tmp1 + tmp3
    z5 = (z3 + z4) * FIX117
    tmp0 *= fix029
    tmp1 *= fix205
    tmp2 *= fix307
    tmp3 *= fix150
    z1 *= FIX089
    z2 *= FIX256
    z3 *= FIX196
    z4 *= FIX039
    z3 += z5
    z4 += z5
    tmp0 += z1 + z3
    tmp1 += z2 + z4
    tmp2 += z2 + z3
    tmp3 += z1 + z4
    ptr1[idctw*0] = descale12(tmp10 + tmp3) 
    ptr1[idctw*7] = descale12(tmp10 - tmp3) 
    ptr1[idctw*1] = descale12(tmp11 + tmp2) 
    ptr1[idctw*6] = descale12(tmp11 - tmp2) 
    ptr1[idctw*2] = descale12(tmp12 + tmp1) 
    ptr1[idctw*5] = descale12(tmp12 - tmp1) 
    ptr1[idctw*3] = descale12(tmp13 + tmp0) 
    ptr1[idctw*4] = descale12(tmp13 - tmp0) 
    
  End If
  ptr1+=1
  pqnt+=1
  
Next

ptr1=vector
'column calcs
For v = 0 To 7
  z2 = ptr1[ 2]
  z3 = ptr1[ 6]
  z1 = (z2 + z3) * FIX054
  tmp2 = z1 + (z3 * FIX184)
  tmp3 = z1 + (z2 * FIX076)
  tmp0 = (ptr1[ 0] + ptr1[ 4])Shl 13
  tmp1 = (ptr1[ 0] - ptr1[ 4])Shl 13
  tmp10 = tmp0 + tmp3
  tmp13 = tmp0 - tmp3
  tmp11 = tmp1 + tmp2
  tmp12 = tmp1 - tmp2
  tmp0 = ptr1[ 7]
  tmp1 = ptr1[ 5]
  tmp2 = ptr1[ 3]
  tmp3 = ptr1[ 1]
  z1 = tmp0 + tmp3
  z2 = tmp1 + tmp2
  z3 = tmp0 + tmp2
  z4 = tmp1 + tmp3
  z5 = (z3 + z4) * FIX117
  tmp0 *= fix029
  tmp1 *= fix205
  tmp2 *= fix307
  tmp3 *= fix150
  z1 *= FIX089
  z2 *= FIX256
  z3 *= FIX196
  z4 *= FIX039
  z3 +=  z5
  z4 +=  z5
  tmp0 += z1 + z3
  tmp1 += z2 + z4
  tmp2 += z2 + z3
  tmp3 += z1 + z4
  ptr1[ 0] = descale17(tmp10 + tmp3)
  ptr1[ 7] = descale17(tmp10 - tmp3)
  ptr1[ 1] = descale17(tmp11 + tmp2)
  ptr1[ 6] = descale17(tmp11 - tmp2)
  ptr1[ 2] = descale17(tmp12 + tmp1)
  ptr1[ 5] = descale17(tmp12 - tmp1)
  ptr1[ 3] = descale17(tmp13 + tmp0)
  ptr1[ 4] = descale17(tmp13 - tmp0)
  
  ptr1+=8  
  
Next

End Sub
'
'---------------------------------------------------------------------------
Function JPEGgetstr (num As Integer) As String
'gets an array of bytes from a JPEG file and returns them as a string
If num=0 Then Function="":Exit Function
Dim As String a
Dim As Integer i
'print num
a = Space(num)
'I can't do a single GET as i'm using a buffered file access

For i = 0 To num-1
  a[i] = JPEGGetByte
Next

Function=a

End Function
'
'---------------------------------------------------------------------------
Function JPEGGetWord As Long
'gets a big endian word from the current position in file
Dim As Integer temp
temp = JPEGGetByte
Function =  (temp  Shl 8) + JPEGGetByte
End Function
'
'---------------------------------------------------------------------------
Sub JPEGMakeHuffTree(Byref Actables As Integer,Byref Dctables As Integer,Byref tni As Integer,Byref tindx As Integer)
'Called by JpegGetParams whenever it founds a Huffman table marker
'It reads Huffman table and converts it into a binary tree  
'the tree is formed by pairs of integers. The even element corresponds to
'a zero in the code, the right maps to a 1. If an element is negative it is
'an index to a branch. If the element is positive, it is a leaf and the value
'is a code.

Dim As Integer l0,c0,tc,th,i,s,x,_ptr,nxt,temp0,nxtfree,bitt
Dim As Long curnum
'chunk size, counter
jpeg.pendbytes = JPEGGetWord&-2
'number of coefficients for each size
Redim As Integer huffamount(1 To 16)

Do
  'read a table
  temp0 = JPEGGetByte
  tc = temp0 Shr 4
  th = temp0 And 15
  
  'read number of entries for each size
  For i = 1 To 16
    huffamount(i) = JPEGGetByte
    'print huffamount (i), 
  Next i
  'create huffman tree in a single array
  
  'save start of this tree
  huffstart(th * 2 + tc) = tni
  nxtfree = tni+2
  curnum = 0
  
  For s = 1 To 16               'for each length
    For x = 1 To huffamount(s)   'for each tree entry   
      _ptr=tni
      'for each bit in entry
      For bitt =  (s - 1) To 1 Step -1
        'if bitt is 1
        If curnum And (1 Shl bitt) Then _ptr+=1
        nxt = Hufftree(_ptr)
        'next exists
        If nxt>1 Then
          _ptr = nxt
          'don't exist, create it
        Elseif nxt=1 Then
          Hufftree(_ptr) = nxtfree
          _ptr = nxtfree: nxtfree = nxtfree + 2
        Else 
          Print #1, "Huff tree redundancy"
          Sleep
          Stop
        End If
        
      Next bitt
      If (curnum And 1) Then
        Hufftree(_ptr+1) = jpeggetbyte * -1
      Else
        Hufftree(_ptr) = jpeggetbyte * -1
      End If
      curnum = curnum + 1
    Next x
    curnum = curnum * 2 
  Next s
  If tc Then ACTAbles = ACTAbles + 1 Else DCtables = DCtables + 1
  
  tni = nxtfree
  tindx=tindx+1
Loop Until jpeg.pendbytes=0   'for each table
Redim  huffamount(0)

End Sub

'
'---------------------------------------------------------------------------

Sub JPEGGetParms (jpegsize As Uinteger)
'
'Scans a JPEG to see if we are able to display it. If we are, get Huffman
'and quantization coefs
'When the first baseline start of frame is found, routine is exited
'
'This routine is very tolerant, it accept the different blocks in any order
' In fact a precise sequence should be enforced...
'
'Markers:----------------------------------------------------------------
'FFD8 Start of Image /FFD9 End Of image /FFDA Start of Scan
'
'START OF FRAME      DCT SINGLE   DCT DIFFE   ARITHMETICAL  ARITHMETICAL
'                     FRAME        RENTIAL    SINGLE FRAME  DIFFERENTIAL
'Baseline              FFC0                
'Extended sequential   FFC1         FFC5        FFC9          FFCD
'Progressive           FFC2         FFc6        FFCA          FFCE
'Lossless sequential   FFC3         FFC7        FFCB          FFCF
'
'FFC4 Huffman table  /FFCC Aritmetical table  /FFDB Dequantization table
'FFDC Define Nr of lines /FFDF Expand ref Components /FFDE Define hierarchical
'FFE0 - FFEF App segment /FFF0-FFFD Jpeg extension /FF01 to FFBF Reserved
'FFFE -Comment /  FF00 ==  byte FF
'FFDD -Define restart interval /FFD0 - FFD7 Restart marks  
'---------------------------------------------------------------------------
Dim As Integer e,i,temp4,temp0,temp1,temp2,id,ncomp,getsos,l0,c0
Dim As String imgcomment,marker,d
Dim As Integer tni,tindx,ACTAbles, DCtables,qtables
Redim As Integer hufftree(0 To hufftblsize)
For i=0 To hufftblsize:hufftree(i)=1:Next
  Redim quant(0 To 1,0 To 63) '2 quantization tables (Y, CbCr)
  inscan=1
  tni=0
  tindx = 0:tni=0
  If jfile <> 0 Then
    jpeg.size = Lof(jfile)
  Else
    jpeg.size = jpegsize
  End If
  qtables = 0                            'Initialize some checkpoint variables
  ACTAbles = 0
  DCtables = 0
  jpeg.restart = 0
  
  marker = ""
  Do                                      'Primary control loop for markers
    If JPEGGetByte = 255 Then             'Marker Found
      e = JPEGGetByte
      
      '   marker = marker + CHR(d)
      '? "marker ";hex(d)
      Select Case As Const e                        'which one is it?
      
      Case &HC0, &HC1                      'SOF0-1: Frame marker.Only baseline..
        'get frame attributes
        jpeg.pendbytes = JPEGGetWord&-2     'Length of segment
        temp0 = JPEGGetByte                 'Data precision
        If temp0 <> 8 Then Return 
        jpeg.rows = JPEGGetWord&
        jpeg.cols = JPEGGetWord&
        ncomp = JPEGGetByte         'Number of components
        'get data for each image component (Y-CB-CR)
        For i = 1 To ncomp
          id = JPEGGetByte
          Select Case As Const id
          Case 1
            temp1 = JPEGGetByte
            jpeg.samplesyx = temp1 \ 16
            jpeg.samplesyy = temp1 And 15
            jpeg.qty = JPEGGetByte
          Case 2, 3
            temp1 = JPEGGetByte
            jpeg.samplescbcrx = temp1 \ 16
            jpeg.samplescbcry = temp1 And 15
            jpeg.qtcbr = JPEGGetByte%
          Case Else
            jpegerr=err_mt3comp:Exit Sub
          End Select
        Next i
        
      Case &HC2:jpegerr= err_progframe:Exit Sub
      
      Case &HC5 To &HC7:jpegerr= err_diffframe:Exit Sub
      
      Case &HC9 To &HCF:jpegerr= err_arithcode:Exit Sub
      
      Case &HC4                             'DHT:  Huffman tables
        If ACTAbles < 2 Or DCtables < 2 Then
          JPEGMakeHuffTree (Actables,Dctables,tni,tindx)
        Else
          jpegerr= err_mt2huff:Exit Sub
        End If
        
      Case &HD8 'SOI                        'Start of image.Should not be here
        jpegerr=err_soimispl:Exit Sub
        
      Case &HD9 'EOI                        'END of image.(Should be the EOF)
        jpegerr=err_fnoframe:Exit Sub
      Case &HDA 'SOS                        'start of scan.The true image
        'get scan header parameters 
        'print "scan header found"                             
        jpeg.pendbytes = JPEGGetWord&-2
        temp0 = JPEGGetByte
        If temp0 <> 1 And temp0 <> 3 Then jpegerr= err_mt3comp:Exit Sub
        jpeg.numcomp = temp0
        For i = 1 To temp0
          temp1 = JPEGGetByte
          Select Case As Const temp1
          Case 1
            temp2 = JPEGGetByte
            jpeg.HaCTY = temp2 And 15
            jpeg.HDCTY = temp2 \ 16
          Case 2, 3
            temp2 = JPEGGetByte
            jpeg.HaCTcbr = temp2 And 15
            jpeg.HDCTCBR = temp2 \ 16
          Case Else
            jpegerr= err_mt3comp:Exit Sub
          End Select
        Next i
        
        d = JPEGgetstr(3)
        
        If (DCtables = 2 And ACTAbles = 2 And qtables = 2) Or jpeg.numcomp = 1 Then
          'If we have all tables needed, exit and start displaying the image
          Exit Do
        Else
          jpegerr=err_notalltbl:Exit Sub 
          
        End If
        
      Case &HDD                          'DRI: Define restart interval
        jpeg.pendbytes = JPEGGetWord&-2                  'some images have synch marks embedded..
        jpeg.restart = JPEGGetWord&           'we must skip them
        
      Case &HDB                          'DQT: A quantization table. Read it
        If qtables < 2 Then
          jpeg.pendbytes = JPEGGetWord&-2
          c0 = 2
          Do
            temp0 = JPEGGetByte
            If temp0 And &HF0 Then jpegerr= err_quantprec:Exit Sub
            temp0 = temp0 And 15
            For i = 0 To 63
              quant(temp0, zz(i)) = JPEGGetByte
            Next i
            qtables = qtables + 1
          Loop Until jpeg.pendbytes=0
        Else
          jpegerr=err_mt2qtbl:Exit Sub
        End If
      Case &HE0                          'APP0- application specific data
        jpeg.pendbytes = JPEGGetWord& -2   'We are only interested in JFIF block
        If Left(JPEGgetstr(5),4) <> ("JFIF") Then jpegerr= err_a0notjfif:Exit Sub
        
        'jpeggetbyte
        jpeg.jfifmajor = JPEGGetByte
        jpeg.jfifMinor = JPEGGetByte
        jpeg.densunits = JPEGGetByte
        jpeg.Xdens = JPEGGetWord&
        jpeg.ydens = JPEGGetWord&
        jpeg.ThWidth = JPEGGetByte
        jpeg.Theigth = JPEGGetByte
        
      Case &HFE                          'COM a comment. Just read it
        imgcomment = JPEGgetstr(JPEGGetWord& - 2)
        
      Case &HE1 To &HEF                  'APP1 to AP15  marker. Just skip it
        inscan=0
        d = JPEGgetstr(JPEGGetWord& - 2)
        inscan=1
      Case Else
        jpegerr=err_markunk:Exit Sub
      End Select
    End If
    'IF multikey(1) THEN jpegerr=err_escpress:exit sub
    
  Loop
  
  'return 1 if succesful
  
  
End Sub
'
'---------------------------------------------------------------------------

Function YCrCb2RGB(Y As Integer,cr As Integer,cb As Integer) As Integer
  'convert Y-CR-Cb to rgb
  Static As Integer i,yy, r_g_b(2)
  yy=1000*y
  r_g_b(0)= (yy+1402*Cr)\1000
  r_g_b(1)= (yy-344*cb-714*cr)\1000
  r_g_b(2)= (yy+1772*cb)\1000 
  
  For i = 0 To 2
    
    If r_g_b(i)>255 Then 
      r_g_b(i)=255
    Elseif r_g_b(i)<0 Then 
      r_g_b(i)=0
    End If
    
  Next i
  Return Rgb(r_g_b(0), r_g_b(1), r_g_b(2))
End Function
'
'---------------------------------------------------------------------------
Function JPEGRenderColor (x0 As Integer, y0 As Integer,rndrbuff As Any Ptr) As Integer
  'JPEGGetParams exits when  a SOF marker is found.Then the main loop sets a
  ' SVGA mode and this routine (or the mono one) is called.
  
  'JPEGRenderColor calls decoder for each block, combines them and sends pixels to
  ' screen. It skips Restart markers,checks for screen boundaries,selects
  ' svga banks and draw pixels.
  ' If an image mcu is outside the top, left or right boundaries of the
  ' screen, its blocks are just Huffman decoded, IDCT is skipped. viw flag
  ' controls it. When the bottom of the screen is reached, decoding is just
  ' stopped.
  
  'shared vport AS vportblock
  'shared buf2_ptr AS INTEGER, viw AS INTEGER
  'shared jpeg AS JpegType
  
  'shared rcrv(), gcbv(), gcrv(), bcbv()
  'shared _rgb() AS INTEGER
  
  
  'vectors save the 8x8 blocks returned bu JPEGGet8x8, to be combined in an
  ' image mcu
  
  Dim As Integer dcY,dcCb,dcCr,xindex,yindex,mcu,xinc,yinc,nsy,xrend,yrend,xi0,yi,ylim
  Dim As Integer xi,xlim,y2,j2,yyy,viw,yput
  Dim prgb As Uinteger Ptr
  Dim As Integer Ptr vector, yvector,cbvector,crvector
  
  yvector=Allocate (64*4*4)                     
  cbvector=Allocate (64*4)
  crvector=Allocate (64*4)  
  
  'We initialize the dc coefficients for each component
  'at start and at each restart mark: they are cumulative
  
  dcY = 0: dcCb = 0: dcCr = 0
  'indexes to the image
  xindex = 0: yindex = 0
  'huffman decoder buffer _ptr
  buf2_ptr = 0
  'mcu counter. Used only if restart marks present
  mcu = 0
  'print x0,y0
  'set parameters for 2x2. 2x1, 1x2 ,1x1 files
  xinc=jpeg.samplesyx*8
  yinc=jpeg.samplesyy*8
  nsy=jpeg.samplesyx*jpeg.samplesyy
  
  'prepere an output buffer
  'prgb=ImageCreate(16,16,,32)
  prgb=Allocate(8*8*4+4)
  prgb[0]=(8 Shl 3) Or (8 Shl 16) 'we will pset in 16x16 blocks
  
  'rendering loop
  Do                                     'for each mcu
    'check if present mcu  is fully off screen limits,set viw flag
    'if so we will only partially decode it and will not try to display it
    viw = -1
    xi0 = xindex + x0
    If (xi0 >= vport.xres) Or (xi0+8 < 0) Or((yindex + y0+8) < 0) Then viw=0
    
    'get next blocks from decoder
    vector=yvector  
    For y As Integer =1 To nsy
      JPEGGet8x8 Vector, 1, dcY
      vector+=64 
    Next
    
    JPEGGet8x8 CbVector, 2, dcCb
    JPEGGet8x8 CrVector, 2, dcCr
    
    
    If viw Then 'display the image mcu
      'perform idct's      
      vector=yvector 
      For y As Integer =1 To nsy
        idct Vector, 1
        vector+=64 
      Next
      idct Cbvector,2 
      idct Crvector,2
      
      'combine components, do colorspace transform write to PUT buffer, then PUT it to out buffer
      Dim As Integer xii,yii,xc,yc 
      vector=yvector
      xi=x0+xindex
      yi=y0+yindex
      For x As Integer=0 To jpeg.samplesyy-1
        yii=8*(x) 
        For x1 As Integer =0 To jpeg.samplesyx-1
          xii=8*(x1)    
          
          For y1 As Integer =0 To 7
            For y2 As Integer= 0 To 7 
              yc= y1\jpeg.samplesyx+xii\2+8*(y2\jpeg.samplesyy+yii\2)
              Dim As Integer y= y1+8*y2 
              prgb[y+1]=YCrCb2RGB(vector[y]+128,crvector[yc],cbvector[yc])
            Next
          Next 
          Put rndrbuff,(xi+xii,yi+yii),prgb,Pset
          vector+=64
        Next 
      Next
      
    End If                             'if mcu must be displayed
    
    'if image has restart marks, keep counting nr of elements (mcu)
    If jpeg.restart Then
      mcu = mcu + 1
      'if restart interval reached skip restart mark and reset DC components
      If jpeg.restart = mcu Then
        buf2_ptr = 0:getbytebuffered:getbytebuffered
        dcY = 0: dcCb = 0: dcCr = 0: mcu = 0
      End If
    End If
    
    'move right the graphics cursor to next mcu
    xindex = xindex + xinc
    If jpeg.cols - xindex < xinc Then
      xrend = jpeg.cols - xindex - 1
    Else
      xrend = xinc - 1
    End If
    ' 
    'if right side of image reached, go for next mcu row of mcu's
    If xindex >= jpeg.cols Then
      xindex = 0: xrend = xinc - 1
      yindex = yindex + yinc
      If jpeg.rows - yindex < yinc Then
        yrend = jpeg.rows - yindex - 1
      Else
        yrend = yinc - 1
      End If
      
    End If
    
    'stop if no more mcu's or bottom of  screen reached
  Loop Until yindex >= jpeg.rows Or yindex + y0 >= vport.yres
  
  'kindly free memory for other uses
  Deallocate (yvector)
  Deallocate (crvector)
  Deallocate (cbvector)
  Deallocate (prgb)
  Return 0
End Function
'
'---------------------------------------------------------------------------
Function JPEGRenderMono (x0 As Integer, y0 As Integer,rndrbuff As Any Ptr) As Integer
  
  'monochrome jpeg. This is easy, we have only the Y component, Image elements
  'are 8X8, the same as blocks
  
  'vectors save the 8x8 blocks returned bu JPEGGet8x8, to be combined in an
  ' image mcu
  
  Dim As Integer dcy,xindex,yindex,xi0,y,x,xj,yi,yyy,xlim,ylim,xrend,yrend,viw,mcu,yput
  Dim As Uinteger Ptr prgb
  Dim As Integer Ptr Yvector1
  yvector1=Allocate (64*4)
  
  'We initialize the dc coefficients for each component
  'at start and at each restart mark: they are cumulative
  
  prgb=Allocate(64*4+4):prgb[0]=(8 Shl 3) Or (8 Shl 16)
  dcY = 0 
  xindex = 0: yindex = 0
  buf2_ptr = 0
  mcu = 0
  xlim = vport.xres - x0
  ylim = vport.yres - y0
  xrend = 7: yrend = 7
  Do
    'check if present mcu  is fully off screen limits,set viw flag
    'if so we will only partially decode it and will not try to display it
    viw = -1
    xi0 = xindex + x0
    If (xi0 >= vport.xres) Or (xi0 < 0) Or((yindex + y0) < 0) Then viw=0
    
    'go decode a block
    JPEGGet8x8 YVector1, 1, dcY
    
    
    'If block must be viewed, display it
    If viw Then
      idct yvector1,1  
      'for each line
      For y = 0 To 63
        yyy=yvector1[y]+128
        'clamp the value   
        If yyy < 0 Then
          yyy = 0
        Elseif y > 255 Then
          yyy = 255
        End If
        prgb[y+1] =(yyy Shl 16) Or  (yyy Shl 8) Or yyy
      Next y    'next line
      'display mcu
      Put rndrbuff,(xindex+x0,yindex+y0),prgb,Pset   
      
    End If      'mcu was to be displayed
    
    'if image has restart marks, keep counting nr of elements
    'if restart interval reached skip restart mark and reset DC components
    If jpeg.restart Then
      mcu = mcu + 1:
      If jpeg.restart = mcu Then
        buf2_ptr = 0:getbytebuffered:getbytebuffered
        dcY = 0: mcu = 0
      End If
    End If
    
    'move right the graphics cursor to next mcu
    xindex = xindex + 8
    If jpeg.cols - xindex < 8 Then
      xrend = jpeg.cols - xindex - 1
    Else
      xrend = 7
    End If
    'if right side of image reached, go for next mcu row of mcu's
    If xindex >= jpeg.cols Then
      xindex = 0: xrend = 7
      yindex = yindex + 8
      If jpeg.rows - yindex < 8 Then
        yrend = jpeg.rows - yindex - 1
      Else
        yrend = 7
      End If
      'return -1 if escaped
      'IF multikey(1) THEN
      ' JPEGRenderMono = -1
      ' EXIT DO
      'end if
    End If
    'if at bottom of the image or screen, stop decoding
  Loop Until yindex >= jpeg.rows Or yindex + y0 >= vport.yres
  'be kind and free memory for other uses
  
  'ERASE YVector1
  Deallocate (prgb):Deallocate (yvector1)
  Return 0
End Function
'
'------------------------------------------------------------------------
Sub renderjpeg(x0 As Integer,y0 As Integer,rndrbuff As Any Ptr)
  'decodes a scan and displays the image
  indx=mxind+1
  'init fast buffered file reading and aux bit buffer
  buf2_ptr = -1
  Redim  buff(bsize) As Ubyte
  pbuff=@buff(0)
  'undo the byte pre-fetch used in Getparams
  If jfile <> 0 Then
    Seek jfile,Seek(jfile)-1
  Else
    jpegmem -= 1
  End If
  
  'init tables for GetNbits
  Dim As Integer i,temp
  p1stbit=Allocate(16*4)
  pmaskbits=Allocate(16*4)
  For i = 0 To 15:
    temp = 1 Shl i 
    pmaskbits[i] = temp - 1
    p1stbit[i] = temp Shr 1
  Next
  '
  'go for it...................
  Select Case As Const jpeg.numcomp
  Case 3: JPEGRenderColor( x0, y0,rndrbuff)
  Case 1: JPEGRenderMono( x0, y0,rndrbuff)
  End Select
  
  Redim Hufftree(0), buff(0),quant(0,0)
  Deallocate (p1stbit)
  Deallocate(pmaskbits)
End Sub
'
'-----------------------------------------------------------------------
Function printerror() As String
  Select Case As Const jpegerr 
  Case err_ok       : Function="File succesfully read"
  Case err_escpress : Function="Escape pressed while decoding" 
  Case err_nogfxlib : Function="You Need to set a  SCREEN mod in GfxLib before using jpeg4fb"
  Case err_palmode  : Function="Can't work in paletted modes...yet"
  Case err_nofile   : Function="Requires a jpeg file name"
  'case err_nofile   : function="Could not open file"
  Case err_fnotexist: Function="File does not exist" 
  Case err_fnojpeg  : Function="Not a jpeg file"
  Case err_fnoframe : Function="Can't find a frame in the file"   
  Case err_progframe: Function="Can't decode a progressive frame"
  Case err_diffframe: Function="Can't decode a differential frame"
  Case err_arithcode: Function="Can't read arithmetical encoded jpegs"
  Case err_quantprec: Function="Quantization table is not 8 bit precission"
  Case err_mt2huff  : Function="More than 2 huffman tables per component"
  Case err_soimispl : Function="Misplaced start of image marker"
  Case err_smplsz   : Function="Sample size is not 8 x 8" 
  '  case err_smplsz   : function="More than 3 components"
  Case err_notalltbl: Function="Not all tables read before first scan" 
  Case err_mt2qtbl  : Function="Can't handle more than 2 quantization tables"
  Case err_a0notjfif: Function="Incorrect jfif header"
  Case err_markunk  : Function="Unknown marker found"
  Case err_putbuff  : Function="Can't create the put buffer"
  Case err_scrbuff  : Function="Can't get the screen buffer"
  Case Else         : Function="Unknown error "+Str(jpegerr)
  End Select
End Function
'
'
'---------------------------------------------------------------------------------

Private Function openfile(jpg_file As String) As Integer 'opens file and checks for the jpeg header
  If jpg_file="" Then Return err_nofile 
  If Asc(jpg_file)=34 Then jpg_file=Mid(jpg_file,2,Len(jpg_file)-2)
  jfile = Freefile
  If Open (jpg_file For Binary As #jfile) Then Return err_fnotfound
  If Lof(jfile)=0 Then Close jfile:Kill jpg_file:Return err_fnotexist
  jpeggetbyte      'to feed the read-ahead buffer
  'check for JPEG SOI marker at start
  If JPEGGetWord <> &HFFD8& Then Return err_fnojpeg
End Function
'
'-------------------------------------------------------------------------------
Function jpegget(jpg_file As String,x1 As Integer=-1,y1 As Integer=-1,x2 As Integer=-1,y2 As Integer=-1) As Any Ptr 'buffer returns with a jpeg in it
  jpegerr=0 
  gfxlibon:If jpegerr Then Return 0
  openfile(jpg_file):If jpegerr Then Return 0
  JPEGGetParms(0):If jpegerr Then Close #jfile: Return 0
  If x2>jpeg.cols Then x2=jpeg.cols
  If y2>jpeg.rows Then y2=jpeg.rows
  If x1<0 Then x1=0:x2=jpeg.cols
  If y1<0 Then y1=0:y2=jpeg.rows
  If x1>jpeg.cols Or y1>jpeg.rows Or x2<0 Or y2<0 Then jpegerr =err_getoutl:Return 0
  vport.xres=x2-x1'+1 *****
  vport.yres=y2-y1'+1 *****
  Dim rndrbuff As Any Ptr = imagecreate(vport.xres,vport.yres) 
  If rndrbuff=0 Then jpegerr= err_putbuff:Return 0
  renderjpeg(-x1,-y1,rndrbuff):If jpegerr Then Close #jfile:Return 0 
  Close #jfile
  Function =rndrbuff
End Function
'
'------------------------------------------------------------------------------
Function jpeggetmem(jpegptr As Ubyte Ptr,jpegsize As Uinteger, x1 As Integer=-1,y1 As Integer=-1,x2 As Integer=-1,y2 As Integer=-1) As Any Ptr 'buffer returns with a jpeg in it
  jpegerr=0
  jpegmem=0
  jfile = 0
  gfxlibon:If jpegerr Then Return 0
  jpegmem_ptr = jpegptr
  jpegmem += 3  'eww.. :P
  JPEGGetParms( jpegsize ): If jpegerr Then Return 0
  If x2>jpeg.cols Then x2=jpeg.cols
  If y2>jpeg.rows Then y2=jpeg.rows
  If x1<0 Then x1=0:x2=jpeg.cols
  If y1<0 Then y1=0:y2=jpeg.rows
  If x1>jpeg.cols Or y1>jpeg.rows Or x2<0 Or y2<0 Then jpegerr =err_getoutl:Return 0
  vport.xres=x2-x1'+1 *****
  vport.yres=y2-y1'+1 *****
  Dim rndrbuff As Any Ptr = imagecreate(vport.xres,vport.yres)
  If rndrbuff=0 Then jpegerr= err_putbuff:Return 0
  renderjpeg(-x1,-y1,rndrbuff):If jpegerr Then Return 0
  Function = rndrbuff
End Function
'------------------------------------------------------------------------------
' *****
Sub jpeg2screen(jpg_file As String,x0 As Integer=jpg_center,y0 As Integer=jpg_center,x1 As Integer=0,y1 As Integer=0,x2 As Integer=-1,y2 As Integer=-1)
  
  Dim rndrbuff As Any Ptr
  jpegerr=0
  gfxlibon:If jpegerr Then Exit Sub
  openfile(jpg_file):If jpegerr Then Exit Sub
  
  JPEGGetParms(0): If jpegerr Then Close #jfile:Exit Sub
  
  If x2=-1 Then x2=vport.yres
  If y2=-1 Then y2=vport.yres
  
  If y0=jpg_center Then y0 =((vport.yres - jpeg.rows) \ 2) And &hfffffff0
  If x0=jpg_center Then x0 =((vport.xres - jpeg.cols) \ 2) And &hfffffff0
  
  'print x0,y0,jfile,vport.xres,vport.yres,jpeg.cols,jpeg.rows
  rndrbuff=0 'screenptr
  'if rndrbuff=0 then jpegerr=err_scrbuff:exit sub
  Screenlock 
  renderjpeg(x0,y0,rndrbuff)
  Screenunlock   
  If jpegerr Then Close #jfile:Exit Sub
  Close #jfile
End Sub
'
'
'------------------------------------------------------------------------------
Sub jpegframesize(Byval jpg_file As String,Byref sizex As Integer,Byref sizey As Integer,Byref components As Integer,Byref fmt As Integer)
  'gets size, components format from the first frame found (not in an APP segment) 
  'skip markers up to frame marker
  Dim As Integer n,i
  Dim As String d
  openfile(jpg_file)
  
  Do Until Eof(jfile) 
    n=JpeggetWord()
    Select Case As Const n
    'no FF-00 removal here 
    Case mk_app0 To mk_appf,mk_com
      inscan=0
      d=JPEGgetstr(JPEGGetWord() - 2)
      
      'skip ()
      inscan=-1
      'we found the marker we were searching for 
    Case IS_A_SOF
      Exit Do
      'skip everything else 
    Case Else 'skip( )
      d=JPEGgetstr(JPEGGetWord() - 2)
      
    End Select    
  Loop
  If Eof(jfile) Then Close jfile:jpegerr= err_fnoframe :Exit Sub
  'we are now at a frame marker
  'skip chunk length
  jpeggetword() 
  'skip data item precission
  jpeggetbyte
  'we reached it!
  sizey=jpeggetword()
  sizex=jpeggetword()
  components=jpeggetbyte
  fmt=n And &hff
  'print hex(sizex), sizey,components,fmt
  Close  jfile
End Sub
'----------------------------------------------------------------------