HPDF-1.1: Test/test.hs
---------------------------------------------------------
-- |
-- Copyright : (c) alpha 2007
-- License : BSD-style
--
-- Maintainer : misc@NOSPAMalpheccar.org
-- Stability : experimental
-- Portability : portable
--
-- Test
---------------------------------------------------------
module Main where
import Graphics.PDF
import Penrose
import System.Random
fontDebug :: PDFFont -> PDFString -> Draw ()
fontDebug f t = do
drawText $ do
setFont f
textStart 10 200.0
leading $ getHeight f
renderMode FillText
displayText t
startNewLine
displayText $ toPDFString "Another little test"
strokeColor $ Rgb 1 0 0
stroke $ Line 10 200 612 200
fill $ Circle 10 200 10
stroke $ Rectangle 10 (200.0 - (getDescent f)) (10.0 + textWidth f t) (200.0 - getDescent f + getHeight f)
geometryTest :: Draw ()
geometryTest = do
strokeColor red
stroke $ Rectangle 0 0 200 100
fillColor blue
fill $ Ellipse 100 100 300 200
fillAndStroke $ RoundRectangle 32 32 200 200 600 400
lineStyle ::Draw ()
lineStyle = do
withNewContext $ do
setWidth 2
setDash $ DashPattern [3] 0
geometryTest
shadingTest :: Draw ()
shadingTest = do
paintWithShading (RadialShading 0 0 50 0 0 600 (Rgb 1 0 0) (Rgb 0 0 1)) (addShape $ Rectangle 0 0 300 300)
paintWithShading (AxialShading 300 300 600 400 (Rgb 1 0 0) (Rgb 0 0 1)) (addShape $ Ellipse 300 300 600 400)
patternTest :: PDFReference PDFPage -> PDF ()
patternTest page = do
p <- createUncoloredTiling 0 0 100 50 100 50 ConstantSpacing pattern
cp <- createColoredTiling 0 0 100 50 100 50 ConstantSpacing cpattern
drawWithPage page $ do
strokeColor green
setUncoloredFillPattern p (Rgb 1 0 0)
fillAndStroke $ Ellipse 0 0 300 300
setColoredFillPattern cp
fillAndStroke $ Ellipse 300 300 600 400
where
pattern = do
stroke (Ellipse 0 0 100 50)
cpattern = do
strokeColor (Rgb 0 0 1)
stroke (Ellipse 0 0 100 50)
testAnnotation :: Draw ()
testAnnotation = do
strokeColor red
newAnnotation (URLLink (toPDFString "Go to my blog") [0,0,100,100] "http://www.alpheccar.org" True)
drawText $ text (PDFFont Times_Roman 12) 10 30 (toPDFString "Go to my blog")
stroke $ Rectangle 0 0 100 100
newAnnotation (TextAnnotation (toPDFString "Key annotation") [100,100,130,130] Key)
textTest :: Draw ()
textTest = do
strokeColor red
fillColor blue
fontDebug (PDFFont Times_Roman 48) (toPDFString "This is a test (éèçàù)!")
testImage :: JpegFile -> PDFReference PDFPage -> PDF ()
testImage jpgf page = do
jpg <- createPDFJpeg jpgf
drawWithPage page $ do
withNewContext $ do
setFillAlpha 0.4
drawXObject jpg
withNewContext $ do
applyMatrix $ rotate (Degree 20)
applyMatrix $ translate 200 200
applyMatrix $ scale 2 2
drawXObject jpg
data Normal = Normal deriving(Eq)
data Bold = Bold deriving(Eq)
data Crazy = Crazy deriving(Eq)
data SuperCrazy = SuperCrazy !([Int],[PDFFloat]) deriving(Eq)
data DebugStyle = DebugStyle deriving(Eq)
data RedRectStyle = RedRectStyle deriving(Eq)
data BlueStyle = BlueStyle deriving(Eq)
instance Style Normal where
textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0
styleCode _ = 1
instance Style Bold where
textStyle _ = TextStyle (PDFFont Times_Bold 12) black black FillText 1.0 1.0 1.0 1.0
styleCode _ = 2
instance Style RedRectStyle where
sentenceStyle _ = Just $ \r d -> do
strokeColor red
stroke r
d
return()
textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0
styleCode _ = 5
instance Style DebugStyle where
wordStyle _ = Just $ \r m d ->
case m of
DrawWord -> d >> return ()
DrawGlue -> d >> stroke r
textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0
styleCode _ = 5
crazyWord :: Rectangle -> StyleFunction -> Draw a -> Draw ()
crazyWord r@(Rectangle xa ya xb yb) DrawWord d = do
fillColor $ Rgb 0.6 1 0.6
fill r
d
strokeColor $ Rgb 0 0 1
let m = (ya+yb)/2.0
stroke $ Line xa m xb m
crazyWord (Rectangle xa ya xb yb) DrawGlue _ = do
fillColor $ Rgb 0 0 1
fill (Circle ((xa+xb)/2.0) ((ya+yb)/2.0) ((xb-xa)/2.0))
instance Style Crazy where
sentenceStyle _ = Just $ \r d -> do
d
strokeColor blue
stroke r
wordStyle _ = Just crazyWord
textStyle _ = TextStyle (PDFFont Times_Roman 10) red red FillText 1.0 1.0 1.0 1.0
styleCode _ = 3
superCrazy :: SuperCrazy
superCrazy = SuperCrazy (randomRs (0,32) (mkStdGen 0),randomRs (-10.0,10.0) (mkStdGen 10000))
instance Style SuperCrazy where
styleCode _ = 4
updateStyle (SuperCrazy (a,b)) = SuperCrazy $ (drop 8 a,tail b)
textStyle _ = TextStyle (PDFFont Times_Roman 12) black black FillText 1.0 2.0 0.5 0.5
styleHeight r = (getHeight . textFont . textStyle $ r) + 4.0
styleDescent r = (getDescent . textFont . textStyle $ r) + 2
wordStyle (SuperCrazy (l,_)) = Just ws
where
ws _ DrawGlue _ = return ()
ws (Rectangle xa ya xb yb) DrawWord drawWord = do
let [a,b,c,d,e,f,g,h] :: [PDFFloat] = map (\x -> x / 16.0) . map fromIntegral . take 8 $ l
--angle = head angl
p = Polygon [ (xa-a,ya+b)
, (xb+c,ya+d)
, (xb+e,yb-f)
, (xa-g,yb-h)
, (xa-a,ya+b)
]
strokeColor red
stroke p
fillColor $ Rgb 0.8 1.0 0.8
fill p
withNewContext $ do
--applyMatrix . rotate . Degree $ angle
drawWord
return ()
instance ParagraphStyle Normal where
paraStyleCode _ = 1
data CirclePara = CirclePara deriving(Eq)
data BluePara = BluePara PDFFloat deriving(Eq)
instance ParagraphStyle BluePara where
paraStyleCode _ = 3
lineWidth (BluePara a) w nb = (if nb > 3 then w else w-a) - 20.0
linePosition (BluePara a) _ nb = (if nb > 3 then 0.0 else a) + 10.0
interline _ = Just $ \r -> do
fillColor $ Rgb 0.6 0.6 1
strokeColor $ Rgb 0.6 0.6 1
fillAndStroke r
paraChange s [] = (s,[])
paraChange _ (AChar st c _:l) =
let f = PDFFont Helvetica_Bold 45
w' = charWidth f c
charRect = Rectangle 0 (- getDescent f) w' (getHeight f - getDescent f)
c' = mkLetter (0,0,0) Nothing . mkDrawBox $ do
withNewContext $ do
applyMatrix $ translate (-w') (getDescent f - getHeight f + styleHeight st - styleDescent st)
fillColor $ Rgb 0.6 0.6 1
strokeColor $ Rgb 0.6 0.6 1
fillAndStroke $ charRect
fillColor black
drawText $ do
renderMode AddToClip
textStart 0 0
setFont f
displayText (toPDFString [c])
paintWithShading (AxialShading 0 (- getDescent f) w' (getHeight f - getDescent f) (Rgb 1 0 0) (Rgb 0 0 1)) (addShape charRect)
in
(BluePara w', c':l)
paraChange s l = (s,l)
paragraphStyle _ = Just $ \(Rectangle xa ya xb yb) b -> do
let f = Rectangle (xa-3) (ya-3) (xb+3) (yb+3)
fillColor $ Rgb 0.6 0.6 1
fill f
b
strokeColor red
stroke f
return ()
instance ParagraphStyle CirclePara where
lineWidth _ _ nb =
let nbLines = 15.0
r = nbLines * (getHeight . textFont . textStyle $ Normal)
pasin x' = if x' >= 1.0 then pi/2 else if x' <= -1.0 then (-pi/2) else asin x'
angle l = pasin $ (nbLines - (fromIntegral l) ) / nbLines
in
abs(2*r*cos (angle nb))
linePosition a w nb = max 0 ((w - lineWidth a w nb) / 2.0)
paraStyleCode _ = 2
instance Style BlueStyle where
sentenceStyle _ = Just $ \r d -> do
fillColor $ Rgb 0.6 0.6 1
strokeColor $ Rgb 0.6 0.6 1
fillAndStroke r
d
return()
textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0
styleCode _ = 7
typesetTest :: Int -> PDFReference PDFPage -> PDF ()
typesetTest test page = do
let --symbol = mkDrawBox $ do
-- applyMatrix $ translate 0 (-4)
-- strokeColor red
-- fillColor red
-- fillAndStroke $ Polygon [ (0,0)
-- , (5,5)
-- , (10,0)
-- , (0,0)
-- ]
-- strokeColor blue
-- fillColor blue
-- fillAndStroke $ Polygon [ (0,0)
-- , (5,-5)
-- , (10,0)
-- , (0,0)
-- ]
debugText = do
paragraph $ do
txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor "
setStyle Bold
txt $ "incididunt ut labore et dolore magna aliqua. "
setStyle Normal
txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure "
setStyle RedRectStyle
txt $ "dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. "
setStyle Normal
glue 3 0 0
paragraph $ do
txt $ "Excepteur sint occaecat cupidatat non"
txt $ " proident, sunt in culpa qui officia deserunt mollit anim id est laborum."
setStyle superCrazy
txt $ " And now, a super crazy style to test the code. "
setStyle Normal
txt $ "Return to a normal style :-)"
glue 3 0 0
paragraph $ do
txt $ "More crazy styles ... "
setStyle Crazy
par
setStyle Normal
par = do
txt $ "Lor/-em ip/-sum do/-lor sit am/-et, con/-se/-cte/-tur adi/-pi/-si/-cing el/-it, sed do eius/-mod tem/-por inci/-di/-dunt ut lab/-ore et do/-lo/-re ma/-gna ali/-qua. "
txt $ "Ut en/-im ad mi/-nim ven/-iam, quis no/-strud ex/-er/-ci/-ta/-tion ul/-lam/-co labo/-ris ni/-si ut ali/-quip ex ea com/-mo/-do con/-se/-quat. Duis au/-te ir/-ure "
txt $ "do/-lor in re/-pre/-hen/-der/-it in vo/-lup/-ta/-te ve/-lit es/-se cil/-lum do/-lo/-re eu fu/-giat nul/-la pa/-ria/-tur. Ex/-cep/-teur sint oc/-cae/-cat cu/-pi/-da/-tat non "
txt $ "pro/-id/-ent, sunt in cul/-pa qui of/-fi/-cia de/-se/-runt mol/-lit anim id est la/-bo/-rum."
normalPar = do
txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "
txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor "
txt $ "in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, "
txt $ "sunt in culpa qui officia deserunt mollit anim id est laborum."
myText = do
-- Duplicate paragraph several times
paragraph normalPar
glue 3 0 0
setStyle BlueStyle
setParaStyle (BluePara 0)
setFirstPassTolerance 5000
setSecondPassTolerance 10000
unstyledGlue 3 0 0
paragraph $ do
txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "
txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco "
--addBox symbol 10 10 5
txt $ " laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor "
txt $ "in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, "
txt $ "sunt in culpa qui officia deserunt mollit anim id est laborum."
unstyledGlue 3 0 0
setFirstPassTolerance 100
setSecondPassTolerance 200
setStyle Normal
setParaStyle Normal
glue 3 0 0
paragraph normalPar
glue 3 0 0
paragraph normalPar
--textStart = 300 - getHeight f + getDescent f
maxw = 400
drawWithPage page $ do
--strokeColor red
--setWidth 0.5
--stroke $ Rectangle 10 0 (10+maxw) 300
--stroke $ Line 10 textStart (10+maxw) textStart
strokeColor black
case test of
1 -> do
strokeColor red
stroke $ Line 10 300 (10+maxw) 300
displayFormattedText (Rectangle 10 0 (10+maxw) 300) Normal Normal myText
2 -> do
strokeColor red
stroke $ Line 10 300 (10+maxw) 300
displayFormattedText (Rectangle 10 0 (10+maxw) 300) Normal Normal debugText
3 -> do
let r = (Rectangle 10 200 (10+maxw) 300)
displayFormattedText r CirclePara Normal $ do
setStyle Normal
setFirstPassTolerance 5000
setSecondPassTolerance 5000
setLineSkip 0 0 0
setBaseLineSkip 0 0 0
setLineSkipLimit 0
paragraph $ do
mapM_ (const normalPar) ([1..3]::[Int])
txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "
txt $ "Ut enim ad minim"
strokeColor red
stroke r
_ -> displayFormattedText ((Rectangle 0 300 (10+maxw) 300)) Normal Normal myText
testAll :: JpegFile -> PDF ()
testAll jpg = do
page1 <- addPage Nothing
newSection (toPDFString "Typesetting") Nothing Nothing $ do
newSection (toPDFString "Normal text") Nothing Nothing $ do
typesetTest 1 page1
page2 <- addPage Nothing
newSection (toPDFString "Debug text") Nothing Nothing $ do
typesetTest 2 page2
page3 <- addPage Nothing
newSection (toPDFString "Circle text") Nothing Nothing $ do
typesetTest 3 page3
page4 <- addPage Nothing
newSection (toPDFString "Shapes") Nothing Nothing $ do
newSection (toPDFString "Geometry") Nothing Nothing $ do
drawWithPage page4 $ do
geometryTest
page5 <- addPage Nothing
newSection (toPDFString "Line style") Nothing Nothing $ do
drawWithPage page5 $ do
lineStyle
page6 <- addPage Nothing
newSection (toPDFString "Object reuse") Nothing Nothing $ do
r <- createPDFXForm 0 0 200 200 lineStyle
drawWithPage page6 $ do
drawXObject r
page7 <- addPage Nothing
newSectionWithPage (toPDFString "Painting") Nothing Nothing page7 $ do
newSection (toPDFString "Patterns") Nothing Nothing $ do
patternTest page7
page8 <- addPage Nothing
newSection (toPDFString "Shading") Nothing Nothing $ do
drawWithPage page8 $ do
shadingTest
page9 <- addPage Nothing
newSection (toPDFString "Media") Nothing Nothing $ do
newSection (toPDFString "image") Nothing Nothing $ do
testImage jpg page9
page10 <- addPage Nothing
newSection (toPDFString "Annotations") Nothing Nothing $ do
drawWithPage page10 $ do
testAnnotation
page11 <- addPage Nothing
newSection (toPDFString "Text encoding") Nothing Nothing $ do
drawWithPage page11 $ do
textTest
newSection (toPDFString "Fun") Nothing Nothing $ do
penrose
main :: IO()
main = do
let rect = PDFRect 0 0 600 400
Right jpg <- readJpegFile "logo.jpg"
runPdf "demo.pdf" (standardDocInfo { author=toPDFString "alpheccar", compressed = True}) rect $ do
testAll jpg