--------------------------------------------------------- -- | -- 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