hps-cairo 0.2 → 0.11
raw patch · 7 files changed
+200/−29 lines, 7 filesdep +hps-cairodep +randomdep ~hpssetup-changednew-component:exe:hps-cairo-animationnew-component:exe:hps-cairo-screen
Dependencies added: hps-cairo, random
Dependency ranges changed: hps
Files
- Graphics/PS/Cairo.hs +52/−19
- Help/animation.hs +76/−0
- Help/screen.hs +42/−0
- README +3/−1
- Setup.hs +3/−0
- Setup.lhs +0/−3
- hps-cairo.cabal +24/−6
Graphics/PS/Cairo.hs view
@@ -1,3 +1,4 @@+-- | Cairo rendering for 'P.Image' from @hps@. module Graphics.PS.Cairo (renderImage, cg) where import Data.IORef@@ -20,18 +21,22 @@ case path of P.MoveTo (Pt x y) -> C.moveTo x y P.LineTo (Pt x y) -> C.lineTo x y- P.CurveTo (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) -> C.curveTo x1 y1 x2 y2 x3 y3+ P.CurveTo (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) ->+ C.curveTo x1 y1 x2 y2 x3 y3+ P.ClosePath (Pt x y) -> C.lineTo x y >> C.closePath P.Text f t -> applyFont f >> C.textPath t- P.PTransform m p -> C.save >> applyMatrix m >> renderPath p >> C.restore+ P.PTransform m p ->+ C.save >> applyMatrix m >> renderPath p >> C.restore P.Join p1 p2 -> renderPath p1 >> renderPath p2 setGS :: GS -> C.Render ()-setGS (GS (RGB r b g) w k j _ _) = do +setGS (GS (RGB r g b) w k j _ _) = do C.setSourceRGBA r g b 0.75 C.setLineWidth w C.setLineCap (lineCap k) C.setLineJoin (lineJoin j) +-- | Render an 'P.Image' in cairo. renderImage :: P.Image -> C.Render () renderImage image = case image of@@ -42,36 +47,64 @@ P.Over i1 i2 -> renderImage i1 >> renderImage i2 lineCap :: LineCap -> C.LineCap-lineCap RoundCap = C.LineCapRound-lineCap ButtCap = C.LineCapButt-lineCap ProjectingSquareCap = C.LineCapSquare+lineCap c =+ case c of+ RoundCap -> C.LineCapRound+ ButtCap -> C.LineCapButt+ ProjectingSquareCap -> C.LineCapSquare lineJoin :: LineJoin -> C.LineJoin-lineJoin MiterJoin = C.LineJoinMiter-lineJoin RoundJoin = C.LineJoinRound-lineJoin BevelJoin = C.LineJoinBevel+lineJoin j =+ case j of+ MiterJoin -> C.LineJoinMiter+ RoundJoin -> C.LineJoinRound+ BevelJoin -> C.LineJoinBevel ----cg :: String -> Paper -> [P.Image] -> IO ()-cg _ (Paper w h) pp = do- G.initGUI+cg' :: String -> Paper -> [P.Image] -> IO ()+cg' _ (Paper w h) pp = do+ _ <- G.initGUI window <- G.windowNew canvas <- G.drawingAreaNew n <- newIORef 0 G.windowSetResizable window False G.widgetSetSizeRequest window w h- G.onKeyPress window (\_ -> modifyIORef n (+ 1) >> - G.widgetQueueDraw window >> - return True)- G.onDestroy window G.mainQuit- G.onExpose canvas (const (updateCanvas n canvas pp))+ _ <- G.onKeyPress window (\_ -> modifyIORef n (+ 1) >>+ G.widgetQueueDraw window >>+ return True)+ _ <- G.onDestroy window G.mainQuit+ _ <- G.onExpose canvas (const (updateCanvas n canvas pp)) G.set window [G.containerChild G.:= canvas] G.widgetShowAll window G.mainGUI -updateCanvas :: (G.WidgetClass w) => IORef Int -> w -> [P.Image] -> IO Bool+updateCanvas :: (G.WidgetClass w) =>+ IORef Int -> w -> [P.Image] -> IO Bool updateCanvas n canvas pp = do window <- G.widgetGetDrawWindow canvas k <- readIORef n G.renderWithDrawable window (renderImage (cycle pp !! k)) return True++p_xflip :: Int -> P.Path -> P.Path+p_xflip x path =+ case path of+ P.Join p q -> P.Join (p_xflip x p) (p_xflip x q)+ P.Text f s ->+ let m = P.Matrix 1.0 0.0 0.0 1.0 0.0 (fromIntegral x)+ in P.PTransform m (P.Text f s)+ _ ->+ let m = P.Matrix 1.0 0.0 0.0 (-1.0) 0.0 (fromIntegral x)+ in P.PTransform m path++i_xflip :: Int -> P.Image -> P.Image+i_xflip x image =+ case image of+ P.Stroke g p -> P.Stroke g (p_xflip x p)+ P.Fill g p -> P.Fill g (p_xflip x p)+ P.ITransform m i -> P.ITransform m (i_xflip x i)+ P.Over i j -> P.Over (i_xflip x i) (i_xflip x j)+ P.Empty -> P.Empty++-- | Cairo rendering variant of 'P.ps'.+cg :: String -> Paper -> [P.Image] -> IO ()+cg fn (Paper w h) pp = cg' fn (Paper w h) (map (i_xflip h) pp)
+ Help/animation.hs view
@@ -0,0 +1,76 @@+module Main where++import System.Random+import Graphics.PS+import Graphics.PS.Cairo+import qualified Graphics.UI.Gtk as G+import Data.IORef++type R = Double+data A = A R R R R++semiann :: A -> R -> Image+semiann (A gs ir xr a) sa =+ let x = 250+ y = 250+ z = 250+ sa' = sa * 2.0 * pi+ a' = a * pi+ ir' = min ir xr+ xr' = max ir xr+ shift = translate x y . scale z z+ in Fill (greyGS gs) (shift (annular origin ir' xr' sa' a'))++-- | Group a list into a list of n element lists.+clump :: Int -> [a] -> [[a]]+clump _ [] = []+clump n l =+ let (i,j) = splitAt n l+ in i : clump n j++-- | Generate a list of n random numbers in the range [l,r].+randn :: Int -> Int -> R -> R -> [R]+randn s n l r =+ let f i = i * (r - l) + l+ in (map f . take n . randoms . mkStdGen) s++--+settings :: [(A, R, R)]+settings =+ let g [a,b,c,d,e,f] = (A a b c d, e, f)+ g _ = undefined+ in map g (clump 6 (randn 0 66 0 1))++as :: [A]+as = map (\(a,_,_) -> a) settings++ns :: [R]+ns = map (\(_,n,_) -> n/100) settings++is :: [R]+is = map (\(_,_,i) -> i) settings++main :: IO ()+main = do+ _ <- G.initGUI+ window <- G.windowNew+ canvas <- G.drawingAreaNew+ ss <- newIORef is+ G.windowSetResizable window False+ G.widgetSetSizeRequest window 500 500+ _ <- G.onKeyPress window (const (G.widgetDestroy window >> return True))+ _ <- G.onDestroy window G.mainQuit+ _ <- G.onExpose canvas (const (updateCanvas canvas ss))+ _ <- G.timeoutAdd (G.widgetQueueDraw window >> return True) 42+ G.set window [G.containerChild G.:= canvas]+ G.widgetShowAll window+ G.mainGUI++updateCanvas :: G.DrawingArea -> IORef [R] -> IO Bool+updateCanvas canvas ss = do+ window <- G.widgetGetDrawWindow canvas+ modifyIORef ss (zipWith (+) ns)+ aa <- readIORef ss+ let i = foldl1 over (zipWith semiann as aa)+ G.renderWithDrawable window (renderImage i)+ return True
+ Help/screen.hs view
@@ -0,0 +1,42 @@+module Main where++import Graphics.PS+import Graphics.PS.Cairo++drawPath :: (GS -> a -> b) -> Double -> a -> b+drawPath m g p = m (greyGS g) p++drawCircle :: Pt -> Double -> Image+drawCircle p r =+ let c = arc p r 0 (2 * pi)+ in drawPath Stroke 0.2 c++drawRectangle :: Pt -> Double -> Double -> Double -> Image+drawRectangle p w h a =+ let r = rectangle p w h+ in drawPath Fill 0.4 (rotate a r)++drawText :: Pt -> [Glyph] -> Double -> Image+drawText p t n =+ let t' = Text (Font "Times" n) t+ in drawPath Stroke 0.2 (MoveTo p +++ t')++showCoords :: Image+showCoords =+ let to_n n = [0::Int,100..n]+ cs = [(x, y) | x <- to_n 800, y <- to_n 500]+ i = fromIntegral+ f (x,y) = drawText (Pt (i x) (i y)) (show (x,y)) 12+ in foldl1 over (map f cs)++scena :: Double -> [Image]+scena n =+ let p = Pt 250 250+ r = map (\a -> drawRectangle p 25 35 (pi/12*n*a)) [0..4]+ in [ showCoords+ , drawCircle p (25 * n)+ , drawCircle p (65 * n)+ , drawText p "Some text" (24 * n) ] ++ r++main :: IO ()+main = cg "test.ps" (Paper 900 600) (scena 1.0)
README view
@@ -2,5 +2,7 @@ trivial cairo rendering, via hps -(c) rohan drape 2006-2010+(c) rohan drape and others, 2006-2011 gpl.2, http://gnu.org/copyleft/+ with contributions by declan murphy+ see darcs history for details
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
hps-cairo.cabal view
@@ -1,27 +1,45 @@ Name: hps-cairo-Version: 0.2+Version: 0.11 Synopsis: Cairo rendering for the haskell postscript library Description: Cairo rendering for the haskell postscript library License: GPL Category: Graphics-Copyright: Rohan Drape, 2006-2010+Copyright: Rohan Drape, 2006-2011 Author: Rohan Drape Maintainer: rd@slavepianos.org Stability: Experimental Homepage: http://slavepianos.org/rd/?t=hps-cairo-Tested-With: GHC == 6.10.3+Tested-With: GHC==7.2.2 Build-Type: Simple-Cabal-Version: >= 1.6+Cabal-Version: >= 1.8 Data-files: README Library- Build-Depends: base == 4.*,+ Build-Depends: base==4.*, cairo, gtk,- hps == 0.2+ hps==0.11.* GHC-Options: -Wall -fwarn-tabs Exposed-modules: Graphics.PS.Cairo++Executable hps-cairo-animation+ hs-source-dirs: Help+ Build-Depends: base==4.*,+ cairo,+ gtk,+ hps==0.11.*,hps-cairo,+ random+ Main-Is: animation.hs+ Ghc-Options: -Wall -fwarn-tabs++Executable hps-cairo-screen+ hs-source-dirs: Help+ Build-Depends: base==4.*,+ cairo,+ hps==0.11.*,hps-cairo+ Main-Is: screen.hs+ Ghc-Options: -Wall -fwarn-tabs Source-Repository head Type: darcs