module MeasuredGraphics(DPath,up,MeasuredGraphics(..),compileMG,emptyMG,emptyMG',measureString,measureImageString,measurePackedString) where
import Geometry
import LayoutRequest
--import Placers2(overlayP)
import AutoPlacer(autoP)
import XDraw
import ResourceIds(GCId)
import Font
import TextExtents(queryTextExtents16K)
import Rects(boundingRect)
import CompiledGraphics
import GCtx(GCtx(..))
import GCAttrs(FontData(..))
import PackedString(unpackPS)
import Utils(lunconcat)
--import CmdLineEnv(argFlag)
import Debug.Trace(trace)

tr :: p -> p -> p
tr p
x p
y = p
y

type DPath = [Int] -- path to a part of a drawing

up :: DPath -> DPath
up :: DPath -> DPath
up [] = []
up DPath
path = DPath -> DPath
forall a. [a] -> [a]
init DPath
path

data MeasuredGraphics
--  = LeafM LayoutRequest GCtx (Rect->[DrawCommand])
	    -- GCtx should be replaced by GCId !
  = LeafM LayoutRequest (Rect->[(GCId,[DrawCommand])])
  | SpacedM Spacer MeasuredGraphics
  | PlacedM Placer MeasuredGraphics
  | MarkM GCtx MeasuredGraphics -- path & Gctx preserving nodes
  | 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 ([(GCId, [DrawCommand])] -> Rect -> [(GCId, [DrawCommand])]
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) = [Char]
-> ([LayoutRequest], CompiledGraphics)
-> ([LayoutRequest], CompiledGraphics)
forall p p. p -> p -> p
tr [Char]
"layoutMG" (([LayoutRequest], CompiledGraphics)
 -> ([LayoutRequest], CompiledGraphics))
-> ([LayoutRequest], CompiledGraphics)
-> ([LayoutRequest], CompiledGraphics)
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 = [Char] -> Rect -> Rect
forall p p. p -> p -> p
tr [Char]
"Rect" (Rect -> Rect) -> Rect -> 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 -> ([Char] -> [LayoutRequest] -> [LayoutRequest]
forall p p. p -> p -> p
tr [Char]
"LeafM"  [LayoutRequest
ll],Rect -> (Rect -> [(GCId, [DrawCommand])]) -> CompiledGraphics
cgLeaf Rect
r Rect -> [(GCId, [DrawCommand])]
rcmds)
	  where [Rect
r] = [Rect]
rs -- bug if length rs/=1 !!
	SpacedM (S Spacer1
spacer1) MeasuredGraphics
mg' -> ([Char] -> [LayoutRequest] -> [LayoutRequest]
forall p p. p -> p -> p
tr [Char]
"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) = [(LayoutRequest, Rect -> Rect)]
-> ([LayoutRequest], [Rect -> Rect])
forall a b. [(a, b)] -> ([a], [b])
unzip (Spacer1 -> [LayoutRequest] -> [(LayoutRequest, Rect -> Rect)]
forall a b. (a -> b) -> [a] -> [b]
map Spacer1
spacer1 [LayoutRequest]
lls)
	        rs' :: [Rect]
rs' = ((Rect -> Rect) -> Rect -> Rect)
-> [Rect -> Rect] -> [Rect] -> [Rect]
forall t t a. (t -> t -> a) -> [t] -> [t] -> [a]
map2' (Rect -> Rect) -> Rect -> Rect
forall a. a -> a
id [Rect -> Rect]
spacer2s [Rect]
rs
	PlacedM (P Placer1
placer1) MeasuredGraphics
mg -> ([Char] -> [LayoutRequest] -> [LayoutRequest]
forall p p. p -> p -> p
tr [Char]
"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] = [Char] -> [Rect] -> [Rect]
forall p p. p -> p -> p
tr ([Char]
"#rs="[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show ([Rect] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rect]
rs)) [Rect]
rs
	ComposedM [] -> ([Char] -> [LayoutRequest] -> [LayoutRequest]
forall p p. p -> p -> p
tr [Char]
"ComposedM []" [],Rect -> [CompiledGraphics] -> CompiledGraphics
cgCompose (Size -> Size -> Rect
Rect Size
origin Size
origin) [])
	ComposedM [MeasuredGraphics]
mgs -> ([Char] -> [LayoutRequest] -> [LayoutRequest]
forall p p. p -> p -> p
tr [Char]
"ComposedM" [LayoutRequest]
lls',Rect -> [CompiledGraphics] -> CompiledGraphics
cgCompose Rect
r [CompiledGraphics]
cgs)
	  where ([[LayoutRequest]]
llss,[CompiledGraphics]
cgs) = [([LayoutRequest], CompiledGraphics)]
-> ([[LayoutRequest]], [CompiledGraphics])
forall a b. [(a, b)] -> ([a], [b])
unzip ((MeasuredGraphics -> [Rect] -> ([LayoutRequest], CompiledGraphics))
-> [MeasuredGraphics]
-> [[Rect]]
-> [([LayoutRequest], CompiledGraphics)]
forall t t a. (t -> t -> a) -> [t] -> [t] -> [a]
map2' MeasuredGraphics -> [Rect] -> ([LayoutRequest], CompiledGraphics)
layoutMG [MeasuredGraphics]
mgs [[Rect]]
rss)
	        lls' :: [LayoutRequest]
lls' = [[LayoutRequest]] -> [LayoutRequest]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LayoutRequest]]
llss
		r :: Rect
r = case [Rect]
rs of
		      [] -> [Char] -> Rect -> Rect
forall a. [Char] -> a -> a
trace ([Char]
"ComposedM, rs=[], length mgs="[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show ([MeasuredGraphics] -> Int
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]
_ -> (Rect -> Rect -> Rect) -> [Rect] -> Rect
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Rect -> Rect -> Rect
boundingRect [Rect]
rs -- !!
	        rss :: [[Rect]]
rss = [[LayoutRequest]] -> [Rect] -> [[Rect]]
forall a1 a2. [[a1]] -> [a2] -> [[a2]]
lunconcat [[LayoutRequest]]
llss [Rect]
rs

measureString'' :: (p -> [Char])
-> (Size -> p -> DrawCommand)
-> p
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
measureString'' p -> [Char]
unpack Size -> p -> DrawCommand
draw p
s (GC GCId
gc FontData
fd) MeasuredGraphics -> f b ho
k =
     (Int -> Int -> Int -> Size -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
(Int -> Int -> Int -> Size -> f b ho) -> f b ho
measure ((Int -> Int -> Int -> Size -> f b ho) -> f b ho)
-> (Int -> Int -> Int -> Size -> f b ho) -> f b ho
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
pSize -> Size -> Size
forall a. Num a => a -> a -> a
+(Int -> Int -> Size
Point Int
0 (Int
hInt -> Int -> Int
forall 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) -- paragraphP bug workaround
     in --trace (unwords ["measureString ",unpack s,"rect",show r]) $
        MeasuredGraphics -> f b 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 :: [Char]
us = p -> [Char]
unpack p
s
    measure :: (Int -> Int -> Int -> Size -> f b ho) -> f b ho
measure Int -> Int -> Int -> Size -> f b ho
k =
      case FontData
fd of
        FS FontStruct
fs -> Int -> Int -> Int -> Size -> f b ho
k Int
a Int
d Int
next Size
size
	  where
	    Rect Size
_ Size
size = FontStruct -> [Char] -> Rect
string_rect FontStruct
fs [Char]
us
	    a :: Int
a = FontStruct -> Int
forall per_char. FontStructF per_char -> Int
font_ascent FontStruct
fs
	    d :: Int
d = FontStruct -> Int
forall per_char. FontStructF per_char -> Int
font_descent FontStruct
fs
	    next :: Int
next = FontStruct -> [Char] -> Int
next_pos FontStruct
fs [Char]
us
	FID FontStruct
fs ->
          let fid :: FontId
fid = FontStruct -> FontId
forall per_char. FontStructF per_char -> FontId
font_id FontStruct
fs
	  in  if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
us
   	      then FontId -> [Char] -> (Int -> Int -> CharStruct -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
FontId -> [Char] -> (Int -> Int -> CharStruct -> f b ho) -> f b ho
queryTextExtents16K FontId
fid [Char]
" " ((Int -> Int -> CharStruct -> f b ho) -> f b ho)
-> (Int -> Int -> CharStruct -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \ Int
a Int
d CharStruct
cs ->
	           Int -> Int -> Int -> Size -> f b ho
k Int
a Int
d Int
0 (Int -> Int -> Size
Point Int
0 (Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d))
	      else FontId -> [Char] -> (Int -> Int -> CharStruct -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
FontId -> [Char] -> (Int -> Int -> CharStruct -> f b ho) -> f b ho
queryTextExtents16K FontId
fid [Char]
us ((Int -> Int -> CharStruct -> f b ho) -> f b ho)
-> (Int -> Int -> CharStruct -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \ Int
a Int
d CharStruct
cs ->
	           Int -> Int -> Int -> Size -> f b ho
k Int
a Int
d (CharStruct -> Int
char_width CharStruct
cs) (Int -> Int -> Size
Point (CharStruct -> Int
char_rbearing CharStruct
cs) (Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d))

measureString' :: (Size -> [Char] -> DrawCommand)
-> (Size -> [Char] -> DrawCommand)
-> [Char]
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
measureString' Size -> [Char] -> DrawCommand
draw8 Size -> [Char] -> DrawCommand
draw16 [Char]
s gctx :: GCtx
gctx@(GC GCId
_ FontData
fd) MeasuredGraphics -> f b ho
k =
    ([Char] -> [Char])
-> (Size -> [Char] -> DrawCommand)
-> [Char]
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
forall (f :: * -> * -> *) p b ho.
FudgetIO f =>
(p -> [Char])
-> (Size -> p -> DrawCommand)
-> p
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
measureString'' [Char] -> [Char]
forall a. a -> a
id Size -> [Char] -> DrawCommand
draw [Char]
s GCtx
gctx MeasuredGraphics -> f b ho
k
  where
    draw :: Size -> [Char] -> DrawCommand
draw =
      case FontData
fd of
        FS FontStruct
fs | (Char, Char) -> Char
forall a b. (a, b) -> b
snd (FontStruct -> (Char, Char)
forall per_char. FontStructF per_char -> (Char, Char)
font_range FontStruct
fs) Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xff' -> Size -> [Char] -> DrawCommand
draw8
	FontData
_ -> Size -> [Char] -> DrawCommand
draw16

measureString :: [Char] -> GCtx -> (MeasuredGraphics -> f b ho) -> f b ho
measureString [Char]
s = (Size -> [Char] -> DrawCommand)
-> (Size -> [Char] -> DrawCommand)
-> [Char]
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
(Size -> [Char] -> DrawCommand)
-> (Size -> [Char] -> DrawCommand)
-> [Char]
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
measureString' Size -> [Char] -> DrawCommand
DrawString Size -> [Char] -> DrawCommand
DrawString16 [Char]
s
measureImageString :: [Char] -> GCtx -> (MeasuredGraphics -> f b ho) -> f b ho
measureImageString [Char]
s = (Size -> [Char] -> DrawCommand)
-> (Size -> [Char] -> DrawCommand)
-> [Char]
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
(Size -> [Char] -> DrawCommand)
-> (Size -> [Char] -> DrawCommand)
-> [Char]
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
measureString' Size -> [Char] -> DrawCommand
DrawImageString Size -> [Char] -> DrawCommand
DrawImageString16 [Char]
s

{- old:
measureString =
  if argFlag "string16bit" False
  then measureString' id DrawString16
  else measureString' id DrawString
-}

measurePackedString :: PackedString -> GCtx -> (MeasuredGraphics -> f b ho) -> f b ho
measurePackedString PackedString
ps = (PackedString -> [Char])
-> (Size -> PackedString -> DrawCommand)
-> PackedString
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
forall (f :: * -> * -> *) p b ho.
FudgetIO f =>
(p -> [Char])
-> (Size -> p -> DrawCommand)
-> p
-> GCtx
-> (MeasuredGraphics -> f b ho)
-> f b ho
measureString'' PackedString -> [Char]
unpackPS Size -> PackedString -> DrawCommand
DrawStringPS PackedString
ps


-- map2' is a lazier version of map2 (aka zipWith)
-- length (map2' f xs ys) = length xs,
-- map2' f xs ys = map2' f xs (ys++repeat undefined)
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
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:(t -> t -> a) -> [t] -> [t] -> [a]
map2' t -> t -> a
f [t]
xs [t]
ys