-- fontfont.e
-- Font routines based on Jiri Babor's fonts
-- Pete Eberlein <xseal@harborside.com>
-- 20 June 98

include machine.e
include wildcard.e

global constant
    BOLD = 1,
    ITALIC = 2, 
    UNDERLINE = 4,
    DIMMED = 8

sequence char, char_widths
integer char_height, baseline_height


sequence all_fonts
all_fonts = {}


global function build_text_image(sequence chars, integer foreground, object background, integer attributes)
    integer x, y, l, dx, fbold
    sequence ch, image, ioffset

    ioffset = repeat(0, char_height)
    if and_bits(attributes, ITALIC) then
        for i = 1 to char_height do
            ioffset[i] = floor((char_height - i) * 0.25 )
        end for
    end if

    fbold = and_bits(attributes, BOLD) != 0
    l = 0
    for i = 1 to length(chars) do
        l = l + char_widths[chars[i]] + fbold
    end for
    image = repeat(repeat(background, l+ioffset[1]), char_height)

    if and_bits(attributes, UNDERLINE) then
        x = 1 + ioffset[baseline_height]
        image[baseline_height][x..x+l-1] = foreground
    end if
    

    if and_bits(attributes, DIMMED) then
        dx = 0
        for c = 1 to length(chars) do
            ch = char[chars[c]]
            for i = 1 to length(ch)-2 by 3 do
                y = ch[i+1]
                x = ch[i] + dx + ioffset[y]
                for xx = x+and_bits(x+y,1) to x+ch[i+2]+fbold by 2 do
                    image[y][xx] = foreground
                end for
            end for
            dx = dx + char_widths[chars[c]] + fbold
        end for
    else
        dx = 0
        for c = 1 to length(chars) do
            ch = char[chars[c]]
            for i = 1 to length(ch)-2 by 3 do
                y = ch[i+1]
                x = ch[i] + dx + ioffset[y]
                image[y][x..x+ch[i+2]+fbold] = foreground
            end for
            dx = dx + char_widths[chars[c]] + fbold
        end for
    end if
    return image
end function

global procedure fselect(integer f)
    char = all_fonts[f][2]
    char_widths = all_fonts[f][3]
    char_height = all_fonts[f][4]
    baseline_height = all_fonts[f][5]
end procedure


global function fload(sequence file_name)
    -- load font file into memory and make available for selection
    integer fn,bw,fc,lc, version, on
    sequence cs, bits
    -- if font is already loaded, do not do it again, just select it
    file_name=lower(file_name)
    for n = 1 to length(all_fonts) do
        if compare(all_fonts[n][1], file_name) = 0 then
            fselect(n)
            return n
        end if
    end for

        fn=open(file_name, "rb")
        if fn=-1 then
            puts(1, "Font load error: " & file_name & " not found !\n")
            abort(1) 
        end if
        fc=getc(fn)
        lc=getc(fn)
        bw=getc(fn)
        char_height=getc(fn)
        version=getc(fn)
        baseline_height=getc(fn)                  -- baseline height
        if baseline_height=0 then baseline_height=char_height end if    -- pre version 3 fonts
        char_widths=repeat(0, lc)
        char=repeat({}, lc)
        for i=fc to lc do 
            if i then 
                char_widths[i] = getc(fn) 
            else
                on = getc(fn)  
            end if 
        end for
        for i=fc to lc do
            cs={}
            for row=1 to char_height do
                bits={}
                for col=1 to bw do 
                    bits=bits & and_bits(getc(fn),{128,64,32,16,8,4,2,1})
                end for
                on = 0  
                for x = 1 to length(bits) do
                    if bits[x] then
                        if on then
                            cs[on] = cs[on] + 1
                        else
                            cs = cs & {x,row,0}
                            on = length(cs)
                        end if
                    elsif on then
                        on = 0
                    end if
                end for       
            end for
            if i then
                char[i] = cs
            end if
        end for
        close(fn)
        all_fonts=append(all_fonts, {file_name, char, char_widths, char_height, baseline_height})
    return length(all_fonts)   -- make the last loaded font current

end function  -- fload


global procedure add_pitch(integer pitch)
    char_widths = char_widths + pitch
end procedure


global procedure rom_font(integer width, integer height)
    sequence regs, charaddr
    integer font_buf, bits, on, mask, x

    regs = repeat(0, 10)
    regs[REG_AX] = #1130
    if width = 8 and height = 8 then
        regs[REG_BX] = #0300  
    elsif (width = 8 or width = 9) and height = 14 then
        regs[REG_BX] = #0200
    elsif (width = 8 or width = 9) and height = 16 then
        regs[REG_BX] = #0600
    else
        return
    end if

    regs = dos_interrupt(#10, regs)
    font_buf = regs[REG_ES] * #10 + regs[REG_BP]
    charaddr = repeat(0, 256)
    for c = 1 to 256 do
        charaddr[c] = c * height
    end for
    charaddr = charaddr + font_buf

    char_widths = repeat(width, 256)
    char_height = height
    baseline_height = height

    if width = 9 then
        if height = 14 then
            regs[REG_BX] = #0500
        elsif height = 16 then
            regs[REG_BX] = #0700
        end if
        regs = dos_interrupt(#10, regs)
        font_buf = regs[REG_ES] * #10 + regs[REG_BP]
        while peek(font_buf) do
            charaddr[peek(font_buf)] = font_buf + 1
            font_buf = font_buf + 1 + height
        end while
    end if
            
    char = repeat({}, 256)
    for newAscii = 1 to 256 do
        for y = 1 to height do
            bits = peek(charaddr[newAscii] + y-1)
            on = 0  x = 8  mask = 1
            while mask < bits do
                if and_bits(bits, mask) then
                    if on then
                        char[newAscii][on] = char[newAscii][on] + 1
                        char[newAscii][on-2] = x
                    else
                        char[newAscii] = char[newAscii] & {x,y,0}
                        on = length(char[newAscii])
                    end if
                elsif on then
                    on = 0
                end if
                x = x - 1
                mask = mask * 2
            end while
        end for
    end for
end procedure