module MeasuredGraphics(DPath,up,MeasuredGraphics(..),compileMG,emptyMG,emptyMG',measureString,measureImageString) where
import Geometry
import LayoutRequest
import AutoPlacer(autoP)
import XDraw
import ResourceIds(GCId)
import Font
import TextExtents(queryTextExtents16K)
import Rects(boundingRect)
import CompiledGraphics
import GCtx(GCtx(..))
import GCAttrs(FontData(..),fontdata2struct)
import Utils(lunconcat)
import Debug.Trace(trace)
tr :: p -> p -> p
tr p
x p
y = p
y
type DPath = [Int]
up :: DPath -> DPath
up :: DPath -> DPath
up [] = []
up DPath
path = forall a. [a] -> [a]
init DPath
path
data MeasuredGraphics
= LeafM LayoutRequest (Rect->[(GCId,[DrawCommand])])
| SpacedM Spacer MeasuredGraphics
| PlacedM Placer MeasuredGraphics
| MarkM GCtx MeasuredGraphics
| ComposedM [MeasuredGraphics]
emptyMG :: Size -> MeasuredGraphics
emptyMG Size
size = LayoutRequest -> MeasuredGraphics
emptyMG' (Size -> Bool -> Bool -> LayoutRequest
plainLayout Size
size Bool
False Bool
False)
emptyMG' :: LayoutRequest -> MeasuredGraphics
emptyMG' LayoutRequest
layout = LayoutRequest
-> (Rect -> [(GCId, [DrawCommand])]) -> MeasuredGraphics
LeafM LayoutRequest
layout (forall a b. a -> b -> a
const [])
compileMG :: (Size -> Size)
-> MeasuredGraphics -> (CompiledGraphics, LayoutRequest)
compileMG Size -> Size
f MeasuredGraphics
mg = (CompiledGraphics
cg,LayoutRequest
req)
where
([LayoutRequest]
reqs,CompiledGraphics
cg) = forall {p} {p}. p -> p -> p
tr String
"layoutMG" forall a b. (a -> b) -> a -> b
$ MeasuredGraphics -> [Rect] -> ([LayoutRequest], CompiledGraphics)
layoutMG MeasuredGraphics
mg [Rect]
places
(LayoutRequest
req0,Rect -> [Rect]
placer2) = Placer -> Placer1
unP Placer
autoP [LayoutRequest]
reqs
req :: LayoutRequest
req = (Size -> Size) -> LayoutRequest -> LayoutRequest
mapLayoutSize Size -> Size
f LayoutRequest
req0
place :: Rect
place = forall {p} {p}. p -> p -> p
tr String
"Rect" forall a b. (a -> b) -> a -> b
$ Size -> Size -> Rect
Rect Size
origin (LayoutRequest -> Size
minsize LayoutRequest
req)
places :: [Rect]
places = Rect -> [Rect]
placer2 Rect
place
layoutMG :: MeasuredGraphics -> [Rect] -> ([LayoutRequest],CompiledGraphics)
layoutMG :: MeasuredGraphics -> [Rect] -> ([LayoutRequest], CompiledGraphics)
layoutMG MeasuredGraphics
mg [Rect]
rs =
case MeasuredGraphics
mg of
MarkM GCtx
_ MeasuredGraphics
mg' -> ([LayoutRequest]
lls,CompiledGraphics -> CompiledGraphics
cgMark CompiledGraphics
cg)
where ([LayoutRequest]
lls,CompiledGraphics
cg) = MeasuredGraphics -> [Rect] -> ([LayoutRequest], CompiledGraphics)
layoutMG MeasuredGraphics
mg' [Rect]
rs
LeafM LayoutRequest
ll Rect -> [(GCId, [DrawCommand])]
rcmds -> (forall {p} {p}. p -> p -> p
tr String
"LeafM" [LayoutRequest
ll],Rect -> (Rect -> [(GCId, [DrawCommand])]) -> CompiledGraphics
cgLeaf Rect
r Rect -> [(GCId, [DrawCommand])]
rcmds)
where [Rect
r] = [Rect]
rs
SpacedM (S Spacer1
spacer1) MeasuredGraphics
mg' -> (forall {p} {p}. p -> p -> p
tr String
"SpaceM" [LayoutRequest]
lls',CompiledGraphics -> CompiledGraphics
cgMark CompiledGraphics
cg)
where ([LayoutRequest]
lls,CompiledGraphics
cg) = MeasuredGraphics -> [Rect] -> ([LayoutRequest], CompiledGraphics)
layoutMG MeasuredGraphics
mg' [Rect]
rs'
([LayoutRequest]
lls',[Rect -> Rect]
spacer2s) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map Spacer1
spacer1 [LayoutRequest]
lls)
rs' :: [Rect]
rs' = forall {t} {t} {a}. (t -> t -> a) -> [t] -> [t] -> [a]
map2' forall a. a -> a
id [Rect -> Rect]
spacer2s [Rect]
rs
PlacedM (P Placer1
placer1) MeasuredGraphics
mg -> (forall {p} {p}. p -> p -> p
tr String
"PlacedM" [LayoutRequest
ll'],CompiledGraphics -> CompiledGraphics
cgMark CompiledGraphics
cg)
where ([LayoutRequest]
lls,CompiledGraphics
cg) = MeasuredGraphics -> [Rect] -> ([LayoutRequest], CompiledGraphics)
layoutMG MeasuredGraphics
mg [Rect]
rs'
(LayoutRequest
ll',Rect -> [Rect]
placer2) = Placer1
placer1 [LayoutRequest]
lls
rs' :: [Rect]
rs' = Rect -> [Rect]
placer2 Rect
r
[Rect
r] = forall {p} {p}. p -> p -> p
tr (String
"#rs="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rect]
rs)) [Rect]
rs
ComposedM [] -> (forall {p} {p}. p -> p -> p
tr String
"ComposedM []" [],Rect -> [CompiledGraphics] -> CompiledGraphics
cgCompose (Size -> Size -> Rect
Rect Size
origin Size
origin) [])
ComposedM [MeasuredGraphics]
mgs -> (forall {p} {p}. p -> p -> p
tr String
"ComposedM" [LayoutRequest]
lls',Rect -> [CompiledGraphics] -> CompiledGraphics
cgCompose Rect
r [CompiledGraphics]
cgs)
where ([[LayoutRequest]]
llss,[CompiledGraphics]
cgs) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall {t} {t} {a}. (t -> t -> a) -> [t] -> [t] -> [a]
map2' MeasuredGraphics -> [Rect] -> ([LayoutRequest], CompiledGraphics)
layoutMG [MeasuredGraphics]
mgs [[Rect]]
rss)
lls' :: [LayoutRequest]
lls' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LayoutRequest]]
llss
r :: Rect
r = case [Rect]
rs of
[] -> forall a. String -> a -> a
trace (String
"ComposedM, rs=[], length mgs="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [MeasuredGraphics]
mgs)) (Int -> Int -> Int -> Int -> Rect
rR Int
0 Int
0 Int
1 Int
1)
[Rect]
_ -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Rect -> Rect -> Rect
boundingRect [Rect]
rs
rss :: [[Rect]]
rss = forall {a1} {a2}. [[a1]] -> [a2] -> [[a2]]
lunconcat [[LayoutRequest]]
llss [Rect]
rs
measureString'' :: (p -> String)
-> (Size -> p -> DrawCommand)
-> p
-> GCtx
-> (MeasuredGraphics -> f hi ho)
-> f hi ho
measureString'' p -> String
unpack Size -> p -> DrawCommand
draw p
s (GC GCId
gc FontData
fd) MeasuredGraphics -> f hi ho
k =
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
(Int -> Int -> Int -> Size -> f hi ho) -> f hi ho
measure forall a b. (a -> b) -> a -> b
$ \ Int
a Int
d Int
next Size
size ->
let p1 :: Size
p1 = Int -> Int -> Size
Point Int
0 Int
a
p2 :: Size
p2 = Int -> Int -> Size
Point Int
next Int
a
drawit :: Rect -> [(GCId, [DrawCommand])]
drawit (Rect Size
p (Point Int
_ Int
h)) = [(GCId
gc,[Size -> p -> DrawCommand
draw (Size
pforall a. Num a => a -> a -> a
+(Int -> Int -> Size
Point Int
0 (Int
hforall a. Num a => a -> a -> a
-Int
d))) p
s])]
size' :: Size
size' = Int -> Int -> Size
Point (Size -> Int
xcoord Size
p2) (Size -> Int
ycoord Size
size)
in
MeasuredGraphics -> f hi ho
k (LayoutRequest
-> (Rect -> [(GCId, [DrawCommand])]) -> MeasuredGraphics
LeafM (Size -> Bool -> Bool -> [Size] -> LayoutRequest
refpLayout Size
size' Bool
True Bool
True [Size
p1,Size
p2]) Rect -> [(GCId, [DrawCommand])]
drawit)
where
us :: String
us = p -> String
unpack p
s
measure :: (Int -> Int -> Int -> Size -> f hi ho) -> f hi ho
measure Int -> Int -> Int -> Size -> f hi ho
k =
case FontData
fd of
FS FontStruct
fs -> Int -> Int -> Int -> Size -> f hi ho
k Int
a Int
d Int
next Size
size
where
Rect Size
_ Size
size = FontStruct -> String -> Rect
string_rect FontStruct
fs String
us
a :: Int
a = forall per_char. FontStructF per_char -> Int
font_ascent FontStruct
fs
d :: Int
d = forall per_char. FontStructF per_char -> Int
font_descent FontStruct
fs
next :: Int
next = FontStruct -> String -> Int
next_pos FontStruct
fs String
us
FID FontStruct
fs ->
let fid :: FontId
fid = forall per_char. FontStructF per_char -> FontId
font_id FontStruct
fs
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
us
then forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
FontId
-> String -> (Int -> Int -> CharStruct -> f hi ho) -> f hi ho
queryTextExtents16K FontId
fid String
" " forall a b. (a -> b) -> a -> b
$ \ Int
a Int
d CharStruct
cs ->
Int -> Int -> Int -> Size -> f hi ho
k Int
a Int
d Int
0 (Int -> Int -> Size
Point Int
0 (Int
aforall a. Num a => a -> a -> a
+Int
d))
else forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
FontId
-> String -> (Int -> Int -> CharStruct -> f hi ho) -> f hi ho
queryTextExtents16K FontId
fid String
us forall a b. (a -> b) -> a -> b
$ \ Int
a Int
d CharStruct
cs ->
Int -> Int -> Int -> Size -> f hi ho
k Int
a Int
d (CharStruct -> Int
char_width CharStruct
cs) (Int -> Int -> Size
Point (CharStruct -> Int
char_rbearing CharStruct
cs) (Int
aforall a. Num a => a -> a -> a
+Int
d))
measureString' :: (Size -> String -> DrawCommand)
-> (Size -> String -> DrawCommand)
-> String
-> GCtx
-> (MeasuredGraphics -> f hi ho)
-> f hi ho
measureString' Size -> String -> DrawCommand
draw8 Size -> String -> DrawCommand
draw16 String
s gctx :: GCtx
gctx@(GC GCId
_ FontData
fd) MeasuredGraphics -> f hi ho
k =
forall {f :: * -> * -> *} {p} {hi} {ho}.
FudgetIO f =>
(p -> String)
-> (Size -> p -> DrawCommand)
-> p
-> GCtx
-> (MeasuredGraphics -> f hi ho)
-> f hi ho
measureString'' forall a. a -> a
id Size -> String -> DrawCommand
draw String
s GCtx
gctx MeasuredGraphics -> f hi ho
k
where
fs :: FontStruct
fs = forall {t}. FontData -> (FontStruct -> t) -> t
fontdata2struct FontData
fd forall a. a -> a
id
draw :: Size -> String -> DrawCommand
draw = if forall a b. (a, b) -> b
snd (forall {per_char}. FontStructF per_char -> (Char, Char)
font_range FontStruct
fs) forall a. Ord a => a -> a -> Bool
<= Char
'\xff' then Size -> String -> DrawCommand
draw8 else Size -> String -> DrawCommand
draw16
measureString :: String -> GCtx -> (MeasuredGraphics -> f hi ho) -> f hi ho
measureString String
s = forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
(Size -> String -> DrawCommand)
-> (Size -> String -> DrawCommand)
-> String
-> GCtx
-> (MeasuredGraphics -> f hi ho)
-> f hi ho
measureString' Size -> String -> DrawCommand
DrawString Size -> String -> DrawCommand
DrawString16 String
s
measureImageString :: String -> GCtx -> (MeasuredGraphics -> f hi ho) -> f hi ho
measureImageString String
s = forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
(Size -> String -> DrawCommand)
-> (Size -> String -> DrawCommand)
-> String
-> GCtx
-> (MeasuredGraphics -> f hi ho)
-> f hi ho
measureString' Size -> String -> DrawCommand
DrawImageString Size -> String -> DrawCommand
DrawImageString16 String
s
map2' :: (t -> t -> a) -> [t] -> [t] -> [a]
map2' t -> t -> a
f [] [t]
_ = []
map2' t -> t -> a
f (t
x:[t]
xs) ~(t
y:[t]
ys) = t -> t -> a
f t
x t
yforall a. a -> [a] -> [a]
:(t -> t -> a) -> [t] -> [t] -> [a]
map2' t -> t -> a
f [t]
xs [t]
ys