{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} import Diagrams.Prelude import Diagrams.Backend.Pdf import Diagrams.Backend.Pdf.CmdLine import Data.Colour (withOpacity) import Graphics.PDF hiding(scale,red,green,blue,white,black,text,rotate,rect,stroke) import qualified Diagrams.Backend.SVG.CmdLine as S import qualified Diagrams.Example.Logo as L import Diagrams.Coordinates ((&)) import qualified Graphics.PDF.Typesetting as T import qualified Graphics.PDF as P import System.Random pageWidth = 600 pageHeight = 400 titleH = 50 data MyParaStyles = Normal | Bold | Crazy | SuperCrazy [Int] [PDFFloat] | DebugStyle | RedRectStyle | BlueStyle instance ComparableStyle MyParaStyles where isSameStyleAs Normal Normal = True isSameStyleAs Bold Bold = True isSameStyleAs Crazy Crazy = True isSameStyleAs (SuperCrazy _ _) (SuperCrazy _ _) = True isSameStyleAs DebugStyle DebugStyle = True isSameStyleAs RedRectStyle RedRectStyle = True isSameStyleAs BlueStyle BlueStyle = True isSameStyleAs _ _ = False instance T.Style MyParaStyles where textStyle Normal = TextStyle (PDFFont Times_Roman 10) P.black P.black FillText 1.0 1.0 1.0 1.0 textStyle Bold = TextStyle (PDFFont Times_Bold 12) P.black P.black FillText 1.0 1.0 1.0 1.0 textStyle RedRectStyle = TextStyle (PDFFont Times_Roman 10) P.black P.black FillText 1.0 1.0 1.0 1.0 textStyle DebugStyle = TextStyle (PDFFont Times_Roman 10) P.black P.black FillText 1.0 1.0 1.0 1.0 textStyle Crazy = TextStyle (PDFFont Times_Roman 10) P.red P.red FillText 1.0 1.0 1.0 1.0 textStyle (SuperCrazy _ _) = TextStyle (PDFFont Times_Roman 12) P.black P.black FillText 1.0 2.0 0.5 0.5 textStyle BlueStyle = TextStyle (PDFFont Times_Roman 10) P.black P.black FillText 1.0 1.0 1.0 1.0 sentenceStyle BlueStyle = Just $ \r d -> do P.fillColor $ Rgb 0.6 0.6 1 P.strokeColor $ Rgb 0.6 0.6 1 P.fillAndStroke r d return() sentenceStyle RedRectStyle = Just $ \r d -> do P.strokeColor P.red P.stroke r d return() sentenceStyle Crazy = Just $ \r d -> do d P.strokeColor P.blue P.stroke r sentenceStyle _ = Nothing wordStyle DebugStyle = Just $ \r m d -> case m of DrawWord -> d >> return () DrawGlue -> d >> P.stroke r wordStyle Crazy = Just crazyWord 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) ] P.strokeColor P.red P.stroke p P.fillColor $ Rgb 0.8 1.0 0.8 P.fill p withNewContext $ do --applyMatrix . rotate . Degree $ angle drawWord return () wordStyle _ = Nothing updateStyle (SuperCrazy a b) = SuperCrazy (drop 8 a) (tail b) updateStyle a = a styleHeight r@(SuperCrazy _ _) = (getHeight . textFont . textStyle $ r) + 4.0 styleHeight r = getHeight . textFont . textStyle $ r styleDescent r@(SuperCrazy _ _) = (getDescent . textFont . textStyle $ r) + 2 styleDescent r = getDescent . textFont . textStyle $ r crazyWord :: Rectangle -> StyleFunction -> Draw a -> Draw () crazyWord r@(Rectangle (xa :+ ya) (xb :+ yb)) DrawWord d = do P.fillColor $ Rgb 0.6 1 0.6 P.fill r d P.strokeColor $ Rgb 0 0 1 let m = (ya+yb)/2.0 P.stroke $ P.Line xa m xb m crazyWord (Rectangle (xa :+ ya) (xb :+ yb)) DrawGlue _ = do P.fillColor $ Rgb 0 0 1 P.fill (Circle ((xa+xb)/2.0) ((ya+yb)/2.0) ((xb-xa)/2.0)) superCrazy :: MyParaStyles superCrazy = SuperCrazy (randomRs (0,32) (mkStdGen 0)) (randomRs (-10.0,10.0) (mkStdGen 10000)) data MyVertStyles = NormalPara | CirclePara | BluePara !PDFFloat instance ComparableStyle MyVertStyles where isSameStyleAs NormalPara NormalPara = True isSameStyleAs CirclePara CirclePara = True isSameStyleAs (BluePara _) (BluePara _) = True isSameStyleAs _ _ = False instance ParagraphStyle MyVertStyles MyParaStyles where lineWidth (BluePara a) w nb = (if nb > 3 then w else w-a) - 20.0 lineWidth CirclePara _ 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)) lineWidth _ w _ = w linePosition (BluePara a) _ nb = (if nb > 3 then 0.0 else a) + 10.0 linePosition a@(CirclePara) w nb = max 0 ((w - P.lineWidth a w nb) / 2.0) linePosition _ _ _ = 0.0 interline (BluePara _) = Just $ \r -> do P.fillColor $ Rgb 0.6 0.6 1 P.strokeColor $ Rgb 0.6 0.6 1 P.fillAndStroke r interline _ = Nothing paragraphChange (BluePara _) _ (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 $ P.translate ((-w') :+ (getDescent f - getHeight f + styleHeight st - styleDescent st)) P.fillColor $ Rgb 0.6 0.6 1 P.strokeColor $ Rgb 0.6 0.6 1 P.fillAndStroke $ charRect P.fillColor P.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) paragraphChange s _ l = (s,l) paragraphStyle (BluePara _) = Just $ \(Rectangle (xa :+ ya) (xb :+ yb)) b -> do let f = Rectangle ((xa-3) :+ (ya-3)) ((xb+3) :+ (yb+3)) P.fillColor $ Rgb 0.6 0.6 1 P.fill f b P.strokeColor P.red P.stroke f return () paragraphStyle _ = Nothing standardStyleTest :: TM MyVertStyles MyParaStyles () standardStyleTest = do paragraph $ do txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut " txt $ "labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris " setStyle Crazy txt $ "nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate " txt $ "velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non " txt $ "proident, sunt in culpa qui officia deserunt mollit anim id est laborum." complexText = centerXY (fst (pdfTextWithSuggestedSize Center 400 200 NormalPara Normal standardStyleTest) === strutY 20 === fst (pdfTextWithSuggestedSize Center 300 200 NormalPara Normal standardStyleTest) # rotate (20 :: Deg) ) <> rect pageWidth (pageHeight - titleH) t s x j = let (td, rd) = pdfLabelWithSuggestedSize (LabelStyle Times_Roman 12 j x blue) s 50 100 in td # showOrigin # lw 0.03 <> rd tfs s x j = let td = pdfLabelWithSize (LabelStyle Times_Roman 12 j x blue) s 50 50 in td # showOrigin # lw 0.03 testpdfsuggestedtextsize = centerXY $ (centerXY squareText) <> rect pageWidth (pageHeight - titleH) where squareText = (t "Top Left" TopLeftCorner LeftJustification ||| t "Top" TopSide Centered ||| t "Top Right" TopRightCorner RightJustification) === (t "Left" LeftSide LeftJustification ||| t "Center" Center Centered ||| t "Right" RightSide RightJustification) === (t "Bottom Left" BottomLeftCorner LeftJustification ||| t "Bottom" BottomSide Centered ||| t "Bottom Right" BottomRightCorner RightJustification) testpdftextsize = centerXY $ (centerXY squareText) <> rect pageWidth (pageHeight - titleH) where squareText = (tfs "Top Left" TopLeftCorner LeftJustification ||| tfs "Top" TopSide Centered ||| tfs "Top Right" TopRightCorner RightJustification) === (tfs "Left" LeftSide LeftJustification ||| tfs "Center" Center Centered ||| tfs "Right" RightSide RightJustification) === (tfs "Bottom Left" BottomLeftCorner LeftJustification ||| tfs "Bottom" BottomSide Centered ||| tfs "Bottom Right" BottomRightCorner RightJustification) testShading = let loopyStar = fc red . mconcat . map (cubicSpline True) . pathVertices . star (StarSkip 3) $ regPoly 7 1 f z d = let s = 20 in loopyStar # scale s # fillRule z # pdfAxialShading (p2 (-1,-1)) (p2 (1,1)) red green # rotate (d :: Deg) in centerXY (hcat (map (f Winding) [0,20,40,60,80,100,120,140,160])) === centerXY (hcat (map (f EvenOdd) [0,20,40,60,80,100,120,140,160])) === square 40 # pdfRadialShading (p2 (0,0)) 5 (p2 (0,0)) 40 blue red testImage img = let url = "http://www.alpheccar.org" in circle 100 <> mconcat (map (\r -> img # scale 0.5 # translateX 100 # rotate r) ([0,20..360] :: [Deg])) <> pdfURL url 100 20 <> fst (pdfLabelWithSuggestedSize (LabelStyle Times_Roman 12 Centered Center blue) url 150 40) mkSection s sect = let (d,_) = pdfLabelWithSuggestedSize (LabelStyle Times_Roman 36 Centered Center blue) s pageWidth pageHeight in do page1 <- addPage Nothing drawWithPage page1 $ do renderDia Pdf (PdfOptions (Dims pageWidth pageHeight)) d sect page s d = header s === content d where header s = let (d,_) = pdfLabelWithSuggestedSize (LabelStyle Times_Roman 24 Centered Center black) s pageWidth titleH in d <> (rect pageWidth titleH # pdfAxialShading (p2 (-pageWidth/2,-titleH/2)) (p2 (pageWidth/2,titleH/2)) blue white) clipRect :: Path R2 clipRect = rect pageWidth (pageHeight - titleH) clipRectDiag :: Diagram Pdf R2 clipRectDiag = stroke clipRect content d = (clipRectDiag # lw 0 <> (centerXY d)) # clipBy clipRect # withEnvelope clipRectDiag mkPage :: String -> Diagram Pdf R2 -> PDF () mkPage s d = do page1 <- addPage Nothing drawWithPage page1 $ do renderDia Pdf (PdfOptions (Dims pageWidth pageHeight)) $ page s d testShadeFroz = w where w :: Diagram Pdf R2 w = rect pageWidth (pageHeight - titleH) <> centerXY ( square 100 # pdfAxialShading (p2 (-50,-50)) (p2 (50,50)) blue white # lw 1.0 === square 50 # freeze # rotate (45 :: Deg) # scale 2 # pdfAxialShading (p2 (-40,-40)) (p2 (40,40)) blue yellow # lw 1.0 ) testOpacity = do page1 <- addPage Nothing drawWithPage page1 $ do renderDia Pdf (PdfOptions (Dims pageWidth pageHeight)) $ w where w :: Diagram Pdf R2 w = let colors = map (blue `withOpacity`) [0.1, 0.2 .. 1.0] colorss = map (black `withOpacity`) [0.1, 0.2 .. 1.0] in hcat' with { catMethod = Distrib, sep = 1 } (zipWith3 (\cs cl c -> fcA cs $ c) colors colorss (repeat (circle 1))) main = do Right jpgf <- readJpegFile "logo.jpg" let theDocRect = PDFRect 0 0 pageWidth pageHeight runPdf "demo.pdf" (standardDocInfo { author=toPDFString "alpheccar", compressed = False}) theDocRect $ do mkSection "HPDF Specific Primitives" $ do jpg <- createPDFJpeg jpgf image <- pdfImage jpg mkPage "Test JPEG and URL" (testImage image) mkPage "Test Shading" testShading mkPage "Test Suggested Text Container Size" testpdfsuggestedtextsize mkPage "Test Forced Text Container Size" testpdftextsize mkPage "Text Complex Text" complexText mkPage "Test shading with freeze" testShadeFroz --