module Font(CharStruct(CharStruct,char_width,char_rbearing),
FontStruct(..),FontStructList(..),
FontStructF(FontStruct,font_id,font_ascent,font_descent,font_prop),
FontDirection(..), FontProp(..), update_font_id, font_range,
split_string, string_len, -- string_rect_mono,
string_rect, string_box_size, string_bounds,
next_pos, poslist, linespace,fsl2fs) where
import Geometry(Point(..), Rect(..), Size, pP, rR, rectsize, xcoord)
import Xtypes(Atom,FontId)
--import Utils(aboth)
--import HbcUtils(mapFst)
import Data.List(mapAccumL)
import Maptrace(ctrace) -- debugging
import Data.Array
--import qualified Data.Array as LA
--import qualified LA -- GHC bug workaround, can't use LA.!
default(Int)
data CharStruct = CharStruct {char_lbearing, char_rbearing,
char_width, char_ascent, char_descent :: Int}
deriving (Eq, Ord, Show, Read)
data FontDirection = FontLeftToRight | FontRightToLeft
deriving (Eq, Ord, Show, Read, Enum)
data FontProp = FontProp Atom Int deriving (Eq, Ord, Show, Read)
-- Only 8-bit characters and 2-byte matrixes. See fsl2fs too!
type FontStruct = FontStructF (Array Char CharStruct)
data FontStructF per_char =
FontStruct {font_id :: FontId,
font_dir :: FontDirection,
first_char, last_char :: Char,
font_complete :: Bool, -- all chars exist
default_char :: Char,
font_prop :: [FontProp],
max_bounds, min_bounds :: CharStruct,
per_char :: Maybe per_char,
font_ascent, font_descent :: Int
-- ^ logical extent above/below baseline for spacing
}
deriving (Eq, Ord, Show, Read)
{-
font_id (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = fid
font_ascent (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = asc
font_descent (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = de
per_char (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = ca
max_bounds (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = maxb
min_bounds (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = minb
font_range (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = (fc,lc)
default_char (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = dc
font_prop (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = fps
-}
font_range fs = (first_char fs,last_char fs)
--update_font_id (FontStruct _ fd fc lc all' dc fps minb maxb ca asc de) fid =
-- FontStruct fid fd fc lc all' dc fps minb maxb ca asc de
update_font_id fs fid = fs{font_id=fid}
linespace fs = font_ascent fs + font_descent fs
char_struct default' fs c =
case per_char fs of
Nothing -> default' fs
Just ca -> --ca ! c
ca ! (if inRange (font_range fs) c -- or: bounds ca
then -- debugging
if inRange (bounds ca) c
then c
else ctrace "fontrange" (font_range fs,bounds ca,c) (default_char fs)
else let c' = default_char fs
in if inRange (bounds ca) c'
then c'
else ctrace "fontrange" (font_range fs,"default char",c') ' ')
lbearing fs = char_lbearing . char_struct min_bounds fs
rbearing fs = char_rbearing . char_struct max_bounds fs
poslist :: FontStruct -> String -> [Int]
poslist fs = map (char_width . char_struct max_bounds fs)
next_pos :: FontStruct -> String -> Int
next_pos fs = sum . poslist fs
-- string_bounds gives enclosing rect with respect to first character's origin
string_bounds :: FontStruct -> String -> Rect
string_bounds fs [] = Rect (Point 0 0) (Point 0 0)
string_bounds fs s =
let cs = char_struct max_bounds fs
x = lbearing fs (head s)
y = -(maximum . map (char_ascent . cs)) s
width = next_pos fs (take (length s - 1) s) + rbearing fs (last s)
height = (maximum . map (char_descent . cs)) s - y
in Rect (Point x y) (Point width height)
string_len :: FontStruct -> String -> Int
string_len fs s = (xcoord . rectsize . string_bounds fs) s
string_rect :: FontStruct -> String -> Rect
string_rect fs s =
rR 0 (-font_ascent fs) (string_len fs s) (linespace fs)
string_box_size :: FontStruct -> String -> Size
string_box_size fs s = pP (next_pos fs s) (linespace fs)
split_string:: FontStruct -> String -> Int -> (String,String,Int)
split_string fs s x =
-- find the first char that ends to the right of the wanted x position
case dropWhile (\(_,_,xr)->xr<x) nxs of
(n,xl,xr):_ ->
-- xl<=x<=xr, wanted x position is inside the nth character
if x-xl<xr-x
then split n -- left edge of nth char is closer
else split (n+1) -- right edge of nth char is closer
[] -> (s,[],n) -- x position is after the last char of the string
where
split n = case splitAt n s of (s1,s2) -> (s1,s2,n)
--n=length s, nxs= string & screen positions of all characters in the string
((n,_),nxs) = mapAccumL (\(n,x) w -> ((n+1,x+w),(n,x,x+w))) ((0,0)::(Int,Int)) ws
-- Width of all characters:
ws = poslist fs s
{- old:
let dist s' = abs (next_pos font s' - x)
nearer (pre1, _, _) (pre2, _, _) = dist pre1 <= dist pre2
better x y = if nearer x y then x else y
in foldr1 better (allsplits s)
--allsplits s = [(take n s, drop n s, n) | n <- [0 .. length s]])
allsplits [] = [([],[],0)]
allsplits xxs@(x:xs) = ([],xxs,0): map (\(xs,ys,n)->(x:xs,ys,n+1)) (allsplits xs)
-}
--------
-- This is a temporary fix until we know how to construct Haskell arrays from C
type FontStructList = FontStructF [CharStruct]
{-
data FontStructList = FontStructList
FontId
FontDirection
Char -- first character
Char -- last character
Bool -- all chars exist
Char -- default char
[FontProp]
CharStruct -- min bounds
CharStruct -- max bounds
(Maybe [CharStruct])
Int -- logical extent above baseline for spacing
Int -- logical extent below baseline for spacing
deriving (Eq, Ord, Show, Read)
-}
--fontl_prop (FontStructList fid fd fc lc all' dc fps minb maxb ca asc de) = fps
fontl_prop = font_prop
fsl2fs (FontStruct fid fd fc lc all' dc fps minb maxb optclist asc de) =
FontStruct fid fd fc lc all' dc fps minb maxb optca asc de
where optca = fmap l2a optclist
l2a clist = array (fc, lc) (zip ixs clist)
-- !! This assumes single byte font, or 2 byte matrix font.
-- !! Linear 16-bit fonts will not work.
-- ! Using a linear array for a 2 byte matrix font wastes space!
ixs = [toEnum (256*byte1+byte2) | byte1<-range (min_byte1,max_byte1),
byte2<-range (min_byte2,max_byte2)]
(min_byte1,min_byte2) = fromEnum fc `divMod` 256
(max_byte1,max_byte2) = fromEnum lc `divMod` 256
{-
-- hack to circumvent limitation in generational garbage collector
data Array a b = Arr (a,a) (LA.Array Int (LA.Array Int b))
deriving (Eq,Ord,Show,Read)
array :: (Ix a, Enum a) => (a,a) -> [(a,b)] -> Array a b
array bds l = Arr bds (LA.listArray (0,dix b2i-dix b1i)
[LA.array rng (filter (inRange rng.fst) (mapFst fromEnum l))
| offs <- [b1i,b1i+maxsize..b2i],
rng <- [(offs,(offs+maxsize-1) `min` b2i)]])
where (b1i,b2i) = aboth fromEnum bds
(!) :: (Ix a, Enum a) => Array a b -> a -> b
(!) (Arr (b1,b2) a) i = (a `LA.sub` dix (ii-fromEnum b1)) `LA.sub` ii where ii = fromEnum i
bounds :: (Ix a, Enum a) => Array a b -> (a,a)
bounds (Arr bds a) = bds
maxsize = 255
dix i = i `div` maxsize
-}