diagrams-cairo (empty) → 0.1
raw patch · 14 files changed
+1108/−0 lines, 14 filesdep +basedep +cairodep +cmdargssetup-changed
Dependencies added: base, cairo, cmdargs, diagrams-core, diagrams-lib, directory, old-time, process, split, unix
Files
- LICENSE +36/−0
- Setup.hs +3/−0
- diagrams-cairo.cabal +37/−0
- example/Fractal.hs +36/−0
- example/Hanoi.hs +58/−0
- example/golden.hs +30/−0
- example/gray.hs +33/−0
- example/hslogo.hs +116/−0
- example/paradox.hs +77/−0
- example/tic-tac-toe/Maps.hs +99/−0
- example/tic-tac-toe/Solve.hs +143/−0
- example/triangular-numbers.hs +81/−0
- src/Diagrams/Backend/Cairo.hs +190/−0
- src/Diagrams/Backend/Cairo/CmdLine.hs +169/−0
+ LICENSE view
@@ -0,0 +1,36 @@+Copyright 2011 diagrams-cairo team:++ Sam Griffin <sam.griffin@gmail.com>+ Luite Stegeman <stegeman@gmail.com>+ Kanchalai Suveepattananont <ksuvee@seas.upenn.edu>+ Ryan Yates <fryguybob@gmail.com>+ Brent Yorgey <byorgey@cis.upenn.edu>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Brent Yorgey nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ diagrams-cairo.cabal view
@@ -0,0 +1,37 @@+Name: diagrams-cairo+Version: 0.1+Synopsis: Cairo backend for diagrams drawing EDSL+Description: This package provides a modular backend for rendering+ diagrams created with the diagrams EDSL using the + Cairo library.+Homepage: http://code.google.com/p/diagrams/+License: BSD3+License-file: LICENSE+Author: Brent Yorgey+Maintainer: byorgey@cis.upenn.edu+Stability: Experimental+Category: Graphics+Build-type: Simple+Cabal-version: >=1.6+Tested-with: GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.3+Extra-source-files: example/*.hs, example/tic-tac-toe/*.hs+Source-repository head+ type: darcs+ location: http://patch-tag.com/r/byorgey/diagrams-cairo++Library+ Exposed-modules: Diagrams.Backend.Cairo+ Diagrams.Backend.Cairo.CmdLine+ Hs-source-dirs: src+ Build-depends: base >= 4.2 && < 4.4,+ process >= 1.0 && < 1.1,+ directory >= 1.0 && < 1.2,+ old-time >= 1.0 && < 1.1,+ diagrams-core >= 0.1 && < 0.2,+ diagrams-lib >= 0.1 && < 0.2,+ cairo >= 0.10.1 && < 0.13,+ cmdargs >= 0.6 && < 0.7,+ split >= 0.1.2 && < 0.2+ if !os(windows)+ cpp-options: -DCMDLINELOOP+ Build-depends: unix >= 2.4 && < 2.5
+ example/Fractal.hs view
@@ -0,0 +1,36 @@+import Diagrams.Prelude++import qualified Data.Colour as C+import Diagrams.Backend.Cairo.CmdLine++type D = Diagram Cairo R2++sierpinski :: Int -> D+sierpinski 1 = t+sierpinski n = s+ ===+ (s ||| s)+ where s = sierpinski (n-1)++t = polygon with { sides = 3, orientation = OrientToX }+ # lw 0+ # fc black++colors = iterate (C.blend 0.1 white) blue++pentaflake :: Int -> D+pentaflake 0 = p+pentaflake n = appends (p' # fc (colors !! (n-1)))+ (zip vs (repeat (rotateBy (1/2) p')))+ where vs = take 5 . iterate (rotateBy (1/5))+ . (if odd n then negateV else id) $ unitY+ p' = pentaflake (n-1)++pentaflake' n = pentaflake n # fc (colors !! n)++p = polygon with { sides = 5, orientation = OrientToX }+ # lw 0++showOrigin d = (circle # fc red # scale (0.05)) `atop` d++main = defaultMain (pad 1.1 $ pentaflake' 4)
+ example/Hanoi.hs view
@@ -0,0 +1,58 @@+import Diagrams.Prelude++import Diagrams.Backend.Cairo.CmdLine++import Data.List++type D = Diagram Cairo R2++colors = [blue, green, red, yellow, purple]++type Disk = Int+type Stack = [Disk]+type Hanoi = [Stack]+type Move = (Int,Int)++renderDisk :: Disk -> D+renderDisk n = square+ # scaleX (fromIntegral n + 2)+ # lc black+ # fc (colors !! n)+ # lw 0.1++renderStack :: Stack -> D+renderStack s = disks `atop` post+ where disks = (vcat . map renderDisk $ s)+ # alignB+ post = square+ # scaleY 6+ # scaleX 0.8+ # lw 0+ # fc saddlebrown+ # alignB++renderHanoi :: Hanoi -> D+renderHanoi = hcat' with {catMethod = Distrib, sep = 7} . map renderStack++solveHanoi :: Int -> [Move]+solveHanoi n = solveHanoi' n 0 1 2+ where solveHanoi' 0 _ _ _ = []+ solveHanoi' n a b c = solveHanoi' (n-1) a c b ++ [(a,c)]+ ++ solveHanoi' (n-1) b a c++doMove :: Move -> Hanoi -> Hanoi+doMove (x,y) h = h''+ where (d,h') = removeDisk x h+ h'' = addDisk y d h'+ removeDisk x h = (head (h!!x), modList x tail h)+ addDisk y d = modList y (d:)++modList i f l = let (xs,(y:ys)) = splitAt i l in xs ++ (f y : ys)++hanoiSequence :: Int -> [Hanoi]+hanoiSequence n = scanl (flip ($)) [[0..n-1], [], []] (map doMove (solveHanoi n))++renderHanoiSeq :: [Hanoi] -> D+renderHanoiSeq = vcat' with { sep = 2 } . map renderHanoi++main = defaultMain (pad 1.1 $ renderHanoiSeq (hanoiSequence 4) # centerY)
+ example/golden.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+import Diagrams.Prelude+import Diagrams.Backend.Cairo.CmdLine++import Data.VectorSpace++type D = Diagram Cairo R2++sq :: D+sq = (lw 1 . stroke $ arc (pi / 2) pi) `atop` (translate (-0.5, 0.5) . lw 0.5 $ square)++phi :: Double+phi = (1 + sqrt 5) / 2++step :: D -> D -> D+step a b = besideAlign (-1,0) (0,1) a b'+ where b' = rotate (-pi/2) . scale (1/phi) $ b++besideAlign :: R2 -> R2 -> D -> D -> D+besideAlign u v a b = beside u b' a+ where b' = translate (v ^* d) b+ (Bounds bb) = bounds b+ (Bounds ba) = bounds a+ d = (ba v - bb v)++golden :: D+golden = pad 1.05 . freeze . scale 100 $ foldr1 step (replicate 10 sq)++main :: IO ()+main = defaultMain golden
+ example/gray.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++import Diagrams.Prelude hiding (gray)+import Diagrams.Backend.Cairo.CmdLine++import Data.List.Split (chunk)+import Data.Maybe (catMaybes)+import Control.Applicative+import Data.Monoid (mconcat)+import Data.List (transpose)++type D = Diagram Cairo R2++gray 0 = [[]]+gray n = map (False:) g ++ map (True:) (reverse g)+ where g = gray (n-1)++rings n = mkRingsDia . map ringOffsets . transpose . gray $ n+ where ringOffsets :: [Bool] -> [(Angle, Angle)]+ ringOffsets = map l2t . chunk 2 . findEdges . zip [0,2*pi/(2^n)..2*pi]+ l2t [x,y] = (x,y)+ l2t [x] = (x,2*pi)++findEdges :: Eq a => [(Angle, a)] -> [Angle]+findEdges = catMaybes . (zipWith edge <*> tail)+ where edge (_,c1) (a,c2) | c1 /= c2 = Just a+ | otherwise = Nothing++mkRingsDia :: [[(Angle, Angle)]] -> D+mkRingsDia = freeze . mconcat . zipWith mkRingDia [2,3..]+ where mkRingDia r = lw 1.05 . mconcat . map (stroke . scale r . uncurry arc)++main = defaultMain $ pad 1.1 (rings 10)
+ example/hslogo.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE TypeFamilies #-}+{- Haskell logo in Diagrams by Ryan Yates.+ Based on Metapost version Brian Sniffen.+ This was based on a public domain PNG by Jeff Wheeler,+ and on logo contest entries by George Pollard, Darrin Thompson, and others.++ (c) 2009 Brian Sniffen, All rights reserved.++ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions+ are met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ 3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+ POSSIBILITY OF SUCH DAMAGE. -}++import Diagrams.Prelude++import Diagrams.Backend.Cairo+import Diagrams.Backend.Cairo.CmdLine++import Data.VectorSpace+import Data.Colour.SRGB++type D = Diagram Cairo R2++mkPath :: [R2] -> D+mkPath = stroke . close . fromVertices . map P++rangle, lambdabody, lambdaleg, lambda :: Double -> Double -> D++rangle h m = mkPath+ [ zeroV, (4*h,4*m*h), (0,8*m*h)+ , (3*h,8*m*h), (7*h,4*m*h), (3*h,0)+ ]+lambdabody h m = translate (4*h,0) (rangle h m)+lambdaleg h m = translate (4*h,0) path+ where path = mkPath [(11*h,0), (8*h,0), (0,8*m*h), (3*h,8*m*h)]++lambda h m = mkPath+ [ (4*h,0), (8*h,4*m*h), (4*h,8*m*h), (7*h,8*m*h)+ , (15*h,0), (12*h,0), (9.5*h,2.5*m*h), (7*h,0)+ ]++-- The equal sign is 5 units high: two units thick in each block,+-- with one unit thickness of white between. Being centered, that+-- puts its outer corners at 3.5, 5.5, 6.5, and 8.5. The right edge+-- is at 17 units. The left edge is the standard 1-unit horizontal+-- gap from the lambda.+-- These gaps are all by horizontal measure---the components are+-- closer than 1 unit to each other.+equalsign :: Double -> Double -> Double -> Double -> D+equalsign h m maxx miny = mkPath q+ where+ maxy = miny + 4/3;+ cutoff = ((16*h,0*h), (8*h,8*m*h))+ p1 = ((maxx*h,miny*m*h), (0*h,miny*m*h)) `intersection` cutoff;+ p2 = ((maxx*h,maxy*m*h), (0*h,maxy*m*h)) `intersection` cutoff;+ q = [p1, p2, (maxx*h,maxy*m*h), (maxx*h,miny*m*h)]++stdrangle, stdlambda, stdlambdabody, stdlambdaleg, lowerequal, upperequal :: D++stdrangle = rangle 1 (3/2)+stdlambda = lambda 1 (3/2)+stdlambdabody = lambdabody 1 (3/2)+stdlambdaleg = lambdaleg 1 (3/2)+lowerequal = equalsign 1 (3/2) 17 (7/3)+upperequal = equalsign 1 (3/2) 17 (13/3)++logo :: D+logo = light stdrangle+ `atop` lighter stdlambda+ `atop` light lowerequal+ `atop` light upperequal+ where light = fc (sRGB 0.4 0.4 0.4)+ lighter = fc (sRGB 0.6 0.6 0.6)++main :: IO ()+main = defaultMain logo++-- If we take the given vectors and put them in R^3 as (x,y,0),+-- we are resulting in the z component of their cross product.+cross3Z :: (Num t) => (t, t) -> (t, t) -> t+cross3Z (x0,y0) (x1,y1) = x0 * y1 - x1 * y0++-- This is just a one off version. A more robust version would+-- included data indicating if the lines were parallel or colinear+-- among other things.+intersection :: (t ~ Scalar t, Fractional t, VectorSpace t) =>+ ((t, t), (t, t)) -> ((t, t), (t, t)) -> (t, t)+intersection (a0,a1) (b0,b1) = a0 ^+^ (va ^* t)+ where vb = b1 ^-^ b0+ va = a1 ^-^ a0+ v = a0 ^-^ b0+ d = cross3Z va vb+ n = cross3Z vb v+ t = n / d
+ example/paradox.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+import Diagrams.Prelude+import Diagrams.Backend.Cairo.CmdLine++import Diagrams.TwoD.Align -- for abbreviations++fibs = 0 : 1 : zipWith (+) fibs (tail fibs)++thick = 0.15++grid x y = frame <> lattice+ where s = square # lw 0.02 # freeze+ frame = square+ # scaleX (fromIntegral x)+ # scaleY (fromIntegral y)+ # lw thick # freeze+ lattice = centerXY . vcat . map hcat . replicate y . replicate x $ s++trap s1 s2 = lw 0 . strokeT . close+ $ fromOffsets [(0,-s2), (s2,0), (0,s1)]+tri s1 s2 = lw 0 . strokeT . close+ $ fromOffsets [(s1,0), (0,s1+s2)]++paradox n drawDiags = sq ||| strutX s2 ||| rect+ where f1 = fibs !! n+ f2 = fibs !! (n+1)+ s1 = fromIntegral f1+ s2 = fromIntegral f2++ trap1 = trap s1 s2 # fc yellow+ trap2 = trap s1 s2 # fc green+ # rotateBy (1/2)++ tri1 = tri s1 s2 # fc red+ tri2 = tri s1 s2 # fc blue++ sq = (if drawDiags then sqDiags else mempty)+ <> grid (f1+f2) (f1+f2)+ <> sqShapes+ sqDiags = (fromVertices [P (0,s2), P (s2,s1)] <>+ fromVertices [P (s2,0), P (s2,s1+s2)] <>+ fromVertices [P (s2,0), P (s1+s2,s1+s2)])+ # stroke+ # lw thick+ # freeze+ # centerXY++ sqShapes = (traps # centerY ||| tris # centerY)+ # centerXY+ traps = trap2 # alignL+ # translateY (s1 - s2)+ <> trap1+ tris = tri1 # alignBL+ <> tri2 # rotateBy (1/2)+ # alignBL++ rect = (if drawDiags then rDiags else mempty)+ <> grid (2*f2 + f1) f2+ <> rShapes++ rShapes = (bot # alignTL <> top # alignTL) # centerXY+ bot = trap1 # alignB ||| rotateBy (-1/4) tri1 # alignB+ top = rotateBy (1/4) tri2 # alignT ||| trap2 # alignT++ rDiags = (fromVertices [P (0,s2), P (2*s2+s1, 0)] <>+ fromVertices [P (s2,0), P (s2,s1)] <>+ fromVertices [P (s1+s2,s2-s1), P (s1+s2,s2)]+ )+ # stroke+ # lw thick+ # lineCap LineCapRound+ # freeze+ # centerXY++dia = paradox 4 True++main = defaultMain (pad 1.1 dia)
+ example/tic-tac-toe/Maps.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++-- Maps of optimal tic-tac-toe play, inspired by similar maps created+-- by Randall Munroe, http://xkcd.com/832/++import Diagrams.Prelude hiding (Result)+import Diagrams.Backend.Cairo.CmdLine++import Data.List.Split (chunk)+import Data.Maybe (fromMaybe, catMaybes)+import qualified Data.Map as M+import Data.Tree+import Control.Arrow (second, (&&&), (***))+import Data.Array (assocs)++import Solve++type D = Diagram Cairo R2++x, o :: D+x = (stroke $ fromVertices [P (-1,1), P (1,-1)] <> fromVertices [P (1,1), P (-1,-1)])+ # lw 0.05+ # lineCap LineCapRound+ # scale 0.4+ # freeze+ # centerXY+o = circle+ # lw 0.05+ # scale 0.4+ # freeze++-- | Render a list of lists of diagrams in a grid.+grid :: [[D]] -> D+grid = centerXY+ . vcat' with {catMethod = Distrib}+ . map (hcat' with {catMethod = Distrib})++-- | Given a mapping from (r,c) locations (in a 3x3 grid) to diagrams,+-- render them in a grid, surrounded by a square.+renderGrid :: M.Map Loc D -> D+renderGrid g+ = (grid+ . chunk 3+ . map (fromMaybe (phantom x) . flip M.lookup g)+ $ [ (r,c) | r <- [0..2], c <- [0..2] ])++ `atop`+ (square # lw 0.02 # scale 3 # freeze)++-- | Given a solved game tree, where the first move is being made by+-- the player for whom the tree is solved, render a map of optimal play.+renderSolvedP :: Tree (Game, Result) -> D+renderSolvedP (Node (Game _ p _, _) []) -- cats game, this player does not+ = renderPlayer (next p) # scale 3 -- get another move; instead of+ -- recursively rendering this game+ -- just render an X or an O+renderSolvedP (Node (Game board player1 _, _)+ [g'@(Node (Game _ _ (Move _ loc : _), res) conts)])+ = renderResult res <> -- Draw a line through a win+ renderGrid cur <> -- Draw the optimal move + current moves+ renderOtherP g' -- Recursively render responses to other moves++ where cur = M.singleton loc (renderPlayer player1 # lc red) -- the optimal move+ <> curMoves board -- current moves++renderSolvedP _ = error "renderSolvedP should be called on solved trees only"++-- | Given a solved game tree, where the first move is being made by the+-- opponent of the player for whom the tree is solved, render a map of optimal+-- play.+renderOtherP :: Tree (Game, Result) -> D+renderOtherP (Node _ conts)+ -- just recursively render each game arising from an opponent's move in a grid.+ = renderGrid . M.fromList . map (getMove &&& (scale (1/3) . renderSolvedP)) $ conts+ where getMove (Node (Game _ _ (Move _ m : _), _) _) = m++-- | Extract the current moves from a board.+curMoves :: Board -> M.Map Loc D+curMoves = M.fromList . (map . second) renderPlayer . catMaybes . map strength . assocs++-- | Render a line through a win.+renderResult :: Result -> D+renderResult (Win _ 0 ls) = winLine # freeze+ where winLine :: D+ winLine = stroke (fromVertices (map (P . conv) ls))+ # lw 0.2+ # lc blue+ # lineCap LineCapRound+ conv (r,c) = (fromIntegral $ c - 1, fromIntegral $ 1 - r)+renderResult _ = mempty++renderPlayer X = x+renderPlayer O = o++xMap = renderSolvedP . solveFor X $ gameTree+oMap = renderOtherP . solveFor O $ gameTree++main = defaultMain (pad 1.1 xMap)+ -- defaultMain (pad 1.1 oMap)
+ example/tic-tac-toe/Solve.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE PatternGuards, ViewPatterns #-}++module Solve where++import Data.Array+import Data.Tree+import Data.Function (on)+import Data.List (groupBy, maximumBy)+import Data.Maybe (isNothing, isJust)+import Data.Monoid+import Control.Applicative (liftA2)+import Control.Arrow ((&&&))+import Control.Monad (guard)++data Player = X | O+ deriving (Show, Eq, Ord)++next X = O+next O = X++data Result = Win Player Int [Loc] -- ^ This player can win in n moves+ | Cats -- ^ Tie game+ deriving (Show, Eq)++compareResultsFor :: Player -> (Result -> Result -> Ordering)+compareResultsFor X = compare `on` resultToScore+ where resultToScore (Win X n _) = (1/(1+fromIntegral n))+ resultToScore Cats = 0+ resultToScore (Win O n _) = (-1/(1+fromIntegral n))+compareResultsFor O = flip (compareResultsFor X)++type Loc = (Int,Int)+type Board = Array Loc (Maybe Player)++emptyBoard :: Board+emptyBoard = listArray ((0,0), (2,2)) (repeat Nothing)++showBoard :: Board -> String+showBoard = unlines . map showRow . groupBy ((==) `on` (fst . fst)) . assocs+ where showRow = concatMap (showPiece . snd)+ showPiece Nothing = " "+ showPiece (Just p) = show p++data Move = Move Player Loc+ deriving Show++makeMove :: Move -> Board -> Board+makeMove (Move p l) b = b // [(l, Just p)]++data Game = Game Board -- ^ The current board state.+ Player -- ^ Whose turn is it?+ [Move] -- ^ The list of moves so far (most+ -- recent first).+ deriving Show++initialGame = Game emptyBoard X []++-- | The full game tree for tic-tac-toe.+gameTree :: Tree Game+gameTree = unfoldTree (id &&& genMoves) initialGame++-- | Generate all possible successor games from the given game.+genMoves :: Game -> [Game]+genMoves (Game board player moves) = newGames+ where validLocs = map fst . filter (isNothing . snd) . assocs $ board+ newGames = [Game (makeMove m board) (next player) (m:moves)+ | p <- validLocs+ , let m = Move player p+ ]++-- | Simple fold for Trees. The Data.Tree module does not provide+-- this.+foldTree :: (a -> [b] -> b) -> Tree a -> b+foldTree f (Node a ts) = f a (map (foldTree f) ts)++-- | Solve the game for player @p@: prune all but the optimal moves+-- for player @p@, and annotate each game with its result (given+-- best play).+solveFor :: Player -> Tree Game -> Tree (Game, Result)+solveFor p = foldTree (solveStep p)++-- | Given a game and its continuations (including their results),+-- solve the game for player p. If it is player p's turn, prune all+-- continuations except the optimal one for p. Otherwise, leave all+-- continuations. The result of this game is the result of the+-- optimal choice if it is p's turn, otherwise the worst possible+-- outcome for p.+solveStep :: Player -> Game -> [Tree (Game, Result)] -> Tree (Game, Result)+solveStep p g@(Game brd curPlayer moves) conts+ | Just res <- gameOver g = Node (g, res) []++ | curPlayer == p = let c = bestContFor p conts+ res = inc . snd . rootLabel $ c+ in Node (g, res) [c]+ | otherwise = Node (g, bestResultFor (next p) conts) conts++bestContFor :: Player -> [Tree (Game, Result)] -> Tree (Game, Result)+bestContFor p = maximumBy (compareResultsFor p `on` (snd . rootLabel))++bestResultFor :: Player -> [Tree (Game, Result)] -> Result+bestResultFor p = inc . snd . rootLabel . bestContFor p++inc :: Result -> Result+inc (Win p n ls) = Win p (n+1) ls+inc Cats = Cats++-- | Check whether the game is over, returning the result if it is.+gameOver :: Game -> Maybe Result+gameOver (Game board _ _)+ = getFirst $ mconcat (map (checkWin board) threes) `mappend` checkCats board++checkWin :: Board -> [Loc] -> First Result+checkWin board = First+ . (>>= winAsResult) -- Maybe Result+ . mapM strength -- Maybe [(Loc, Player)]+ . map (id &&& (board!)) -- [(Loc, Maybe Player)]++winAsResult :: [(Loc, Player)] -> Maybe Result+winAsResult (unzip -> (ls,ps))+ | Just p <- allEqual ps = Just (Win p 0 ls)+winAsResult _ = Nothing++checkCats :: Board -> First Result+checkCats b | all isJust (elems b) = First (Just Cats)+ | otherwise = First Nothing++allEqual :: Eq a => [a] -> Maybe a+allEqual = foldr1 combine . map Just+ where combine (Just x) (Just y) | x == y = Just x+ | otherwise = Nothing+ combine Nothing _ = Nothing+ combine _ Nothing = Nothing++strength :: Functor f => (a, f b) -> f (a,b)+strength (a, f) = fmap ((,) a) f++threes :: [[Loc]]+threes = rows ++ cols ++ diags+ where rows = [ [ (r,c) | c <- [0..2] ] | r <- [0..2] ]+ cols = [ [ (r,c) | r <- [0..2] ] | c <- [0..2] ]+ diags = [ [ (i,i) | i <- [0..2] ]+ , [ (i,2-i) | i <- [0..2] ]+ ]
+ example/triangular-numbers.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++-- Diagrams created for blog post at+-- http://mathlesstraveled.com/2011/04/14/triangular-number-equations-via-pictures-solutions/++import Diagrams.Prelude+import Diagrams.Backend.Cairo.CmdLine++import Data.Colour hiding (atop)++type D = Diagram Cairo R2++tri c n = dots `atop` (strokeT edges # lc c # lw 0.2 # fcA (c `withOpacity` 0.5))+ where rows = map (hcat' with { sep = 1 })+ . zipWith replicate [n,n-1..1]+ . repeat+ $ dot c+ dots = decorateTrail (rotateBy (1/6) edge) rows+ edge = fromOffsets . replicate (n-1) $ unitX # scale 3+ edges = close (edge <> rotateBy (1/3) edge <> rotateBy (2/3) edge)++dot c = circle+ # lw 0+ # fc c++rowSpc = height (rotateBy (1/6) $ strutY 1 :: D)++-- @row k n s c@ draws a row of k size-n triangles with color c,+-- separated by enough space for @s@ dots.+row k n s c = hcat' with {sep = 1 + 3*s} (replicate k (tri c n))++-- 3 T(n) + T(n-1) = T(2n)+law1 n c1 c2 = law3 1 n c1 c2++-- 3T(n) + T(n+1) = T(2n+1)+law2 n c1 c2 = top === strutY rowSpc === (base `atop` mid)+ where base = row 2 n 1 c1+ # centerX+ # alignB+ mid = row 1 n 0 c1+ # reflectY+ # centerX+ # alignB+ top = tri c2 (n+1)+ # centerX++-- (2k+1)T(n) + T(kn - 1) = T((k+1)n)+law3 k n c1 c2 = top === strutY rowSpc === (mid `atop` base)+ where base = row (k+1) n 0 c1 # centerX+ # alignB+ mid = row k n 0 c1 # reflectY+ # centerX+ # alignB+ # translateY (2 + rowSpc)+ top = tri c2 (k*n - 1) # centerX++-- T(n) T(k) + T(n-1) T(k-1) = T(nk)+law4 k n c1 c2 = vcat' with {sep = rowSpc} (map tRow [1..k])+ where tRow k = (row k n 0 c1 # centerX # alignT)+ `atop`+ (row (k-1) (n-1) 1 c2 # reflectY # centerX # alignT)++exampleRow f = hcat' with {sep = 4} . map (alignB . f)++law1Dia = exampleRow law1' [2..4]+ where law1' n = law1 n blue red++law2Dia = exampleRow law2' [1..3]+ where law2' n = law2 n green orange++law3Dia = exampleRow law3' [1..3]+ where law3' k = law3 k 2 saddlebrown gray++law4Dia = exampleRow law4' [2..4]+ where law4' k = law4 k 3 purple gold++-- showOrigin = ((circle # fc red) `atop`)++main = defaultMain (pad 1.05 $ vcat' with {sep=5} . map centerXY $+ [law1Dia -- , law2Dia, law3Dia, law4Dia+ ])
+ src/Diagrams/Backend/Cairo.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , FlexibleContexts+ , TypeSynonymInstances+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Backend.Cairo.CmdLine+-- Copyright : (c) 2011 Diagrams-cairo team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- A full-featured rendering backend for diagrams using Cairo.+--+-----------------------------------------------------------------------------+module Diagrams.Backend.Cairo++ ( Cairo(..) -- rendering token++ , Options(..) -- for CairoOptions, rendering options specific to Cairo+ , OutputFormat(..) -- output format options+ ) where++import Graphics.Rendering.Diagrams.Transform++import Diagrams.Prelude+import Diagrams.TwoD.Ellipse++import qualified Graphics.Rendering.Cairo as C+import qualified Graphics.Rendering.Cairo.Matrix as CM++import Control.Monad (when)+import Data.Maybe (catMaybes)++import Data.Monoid+import qualified Data.Foldable as F++-- | This data declaration is simply used as a token to distinguish+-- this rendering engine.+data Cairo = Cairo++-- | Cairo is able to output to several file formats, which each have+-- their own associated properties that affect the output.+data OutputFormat =+ -- | PNG is unique, in that it is not a vector format+ PNG { pngSize :: (Int, Int) -- ^ the size of the output is given in pixels+ }+ | PS { psSize :: (Double, Double) -- ^ the size of the output is given in points+ }+ | PDF { pdfSize :: (Double, Double) -- ^ the size of the output is given in points+ }+ | SVG { svgSize :: (Double, Double) -- ^ the size of the output is given in points+ }++instance Monoid (Render Cairo R2) where+ mempty = C $ return ()+ (C r1) `mappend` (C r2) = C (r1 >> r2)++instance Backend Cairo R2 where+ data Render Cairo R2 = C (C.Render ())+ type Result Cairo R2 = IO ()+ data Options Cairo R2 = CairoOptions+ { fileName :: String -- ^ the name of the file you want generated+ , outputFormat :: OutputFormat -- ^ the output format and associated options+ }++ withStyle _ s t (C r) = C $ do+ C.save+ r+ cairoTransf t+ cairoStyle s+ C.stroke+ C.restore++ doRender _ options (C r) = do+ let surfaceF surface = C.renderWith surface r+ file = fileName options+ case outputFormat options of+ PNG (w,h) -> do+ C.withImageSurface C.FormatARGB32 w h $ \surface -> do+ surfaceF surface+ C.surfaceWriteToPNG surface file+ PS (w,h) -> C.withPSSurface file w h surfaceF+ PDF (w,h) -> C.withPDFSurface file w h surfaceF+ SVG (w,h) -> C.withSVGSurface file w h surfaceF++ -- Set the line width to 0.01 and line color to black (in case they+ -- were not set), freeze the diagram in its final form, and then do+ -- final adjustments to make it fit the requested size.+ adjustDia _ opts d = d' # lw 0.01 # lc black # freeze+ # scale s+ # translate tr+ where d' = reflectY d -- adjust for cairo's upside-down coordinate system+ (w,h) = getSize $ outputFormat opts+ (wd,hd) = size2D d'+ xscale = w / wd+ yscale = h / hd+ s = let s' = min xscale yscale+ in if isInfinite s' then 1 else s'+ tr = (0.5 *. P (w,h)) .-. (s *. center2D d')++ getSize (PNG (pw,ph)) = (fromIntegral pw, fromIntegral ph)+ getSize (PS sz) = sz+ getSize (PDF sz) = sz+ getSize (SVG sz) = sz++renderC :: (Renderable a Cairo, V a ~ R2) => a -> C.Render ()+renderC a = case (render Cairo a) of C r -> r++cairoStyle :: Style -> C.Render ()+cairoStyle s = foldr (>>) (return ())+ . catMaybes $ [ handle fColor+ , handle lColor -- see Note [color order]+ , handle lWidth+ , handle lCap+ , handle lJoin+ , handle lDashing+ ]+ where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ())+ handle f = f `fmap` getAttr s+ fColor (FillColor (SomeColor c)) = do+ let (r,g,b,a) = colorToRGBA c+ C.setSourceRGBA r g b a+ C.fillPreserve+ lColor (LineColor (SomeColor c)) = do+ let (r,g,b,a) = colorToRGBA c+ C.setSourceRGBA r g b a+ lWidth (LineWidth w) = do+ C.setLineWidth w+ lCap lcap = do+ C.setLineCap (fromLineCap lcap)+ lJoin lj = do+ C.setLineJoin (fromLineJoin lj)+ lDashing (Dashing ds offs) = do+ C.setDash ds offs++cairoTransf :: Transformation R2 -> C.Render ()+cairoTransf t = C.transform m+ where m = CM.Matrix a1 a2 b1 b2 c1 c2+ (a1,a2) = apply t (1,0)+ (b1,b2) = apply t (0,1)+ (c1,c2) = transl t++{- ~~~~ Note [color order]++ It's important for the line and fill colors to be handled in the+ given order (fill color first, then line color) because of the way+ Cairo handles them (both are taken from the sourceRGBA).+-}++fromLineCap :: LineCap -> C.LineCap+fromLineCap LineCapButt = C.LineCapButt+fromLineCap LineCapRound = C.LineCapRound+fromLineCap LineCapSquare = C.LineCapSquare++fromLineJoin :: LineJoin -> C.LineJoin+fromLineJoin LineJoinMiter = C.LineJoinMiter+fromLineJoin LineJoinRound = C.LineJoinRound+fromLineJoin LineJoinBevel = C.LineJoinBevel++instance Renderable Ellipse Cairo where+ render _ ell = C $ do+ let P (xc,yc) = ellipseCenter ell+ (xs,ys) = ellipseScale ell+ th = ellipseAngle ell+ C.newPath+ C.save+ C.translate xc yc+ C.rotate th+ C.scale xs ys+ C.arc 0 0 1 0 (2*pi)+ C.closePath+ C.restore++instance Renderable (Segment R2) Cairo where+ render _ (Linear v) = C $ uncurry C.relLineTo v+ render _ (Cubic (x1,y1) (x2,y2) (x3,y3)) = C $ C.relCurveTo x1 y1 x2 y2 x3 y3++instance Renderable (Trail R2) Cairo where+ render _ (Trail segs c) = C $ do+ mapM_ renderC segs+ when c $ C.closePath++instance Renderable (Path R2) Cairo where+ render _ (Path trs) = C $ C.newPath >> F.mapM_ renderTrail trs+ where renderTrail (tr, P p) = do+ uncurry C.moveTo p+ renderC tr
+ src/Diagrams/Backend/Cairo/CmdLine.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DeriveDataTypeable, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Backend.Cairo.CmdLine+-- Copyright : (c) 2011 Diagrams-cairo team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Convenient creation of command-line-driven executables for+-- rendering diagrams using the Cairo backend.+--+-----------------------------------------------------------------------------++module Diagrams.Backend.Cairo.CmdLine+ ( defaultMain+ , multiMain++ , Cairo+ ) where++import Diagrams.Prelude hiding (width, height)+import Diagrams.Backend.Cairo++import System.Console.CmdArgs.Implicit hiding (args)++import Prelude hiding (catch)++import Data.Maybe (fromMaybe)+import Control.Applicative ((<$>))+import Control.Monad (when)+import Data.List.Split++import System.Environment (getArgs, getProgName)+import System.Directory (getModificationTime)+import System.Process (runProcess, waitForProcess)+import System.IO (openFile, hClose, IOMode(..),+ hSetBuffering, BufferMode(..), stdout)+import System.Exit (ExitCode(..))+import System.Time (ClockTime, getClockTime)+import Control.Concurrent (threadDelay)+import Control.Exception (catch, SomeException(..), bracket)++#ifdef CMDLINELOOP+import System.Posix.Process (executeFile)+#endif++data DiagramOpts = DiagramOpts+ { width :: Int+ , height :: Int+ , output :: FilePath+ , selection :: Maybe String+#ifdef CMDLINELOOP+ , loop :: Bool+ , src :: Maybe String+ , interval :: Int+#endif+ }+ deriving (Show, Data, Typeable)++diagramOpts :: String -> Bool -> DiagramOpts+diagramOpts prog sel = DiagramOpts+ { width = 400+ &= typ "INT"+ &= help "Desired width of the output image (default 400)"++ , height = 400+ &= typ "INT"+ &= help "Desired height of the output image (default 400)"++ , output = def+ &= typFile+ &= help "Output file"++ , selection = def+ &= help "Name of the diagram to render"+ &= (if sel then typ "NAME" else ignore)+#ifdef CMDLINELOOP+ , loop = False+ &= help "Run in a self-recompiling loop"+ , src = def+ &= typFile+ &= help "Source file to watch"+ , interval = 1 &= typ "SECONDS"+ &= help "When running in a loop, check for changes every n seconds."+#endif+ }+ &= summary "Command-line diagram generation."+ &= program prog++defaultMain :: Diagram Cairo R2 -> IO ()+defaultMain d = do+ prog <- getProgName+ args <- getArgs+ opts <- cmdArgs (diagramOpts prog False)+ chooseRender opts d+#ifdef CMDLINELOOP+ when (loop opts) (waitForChange Nothing opts prog args)+#endif++chooseRender :: DiagramOpts -> Diagram Cairo R2 -> IO ()+chooseRender opts d = do+ case splitOn "." (output opts) of+ [""] -> putStrLn "No output file given."+ ps | last ps `elem` ["png", "ps", "pdf", "svg"] -> do+ let outfmt = case last ps of+ "png" -> PNG (width opts, height opts)+ "ps" -> PS (fromIntegral $ width opts, fromIntegral $ height opts)+ "pdf" -> PDF (fromIntegral $ width opts, fromIntegral $ height opts)+ "svg" -> SVG (fromIntegral $ width opts, fromIntegral $ height opts)+ _ -> PDF (fromIntegral $ width opts, fromIntegral $ height opts)+ renderDia Cairo (CairoOptions (output opts) outfmt) d+ | otherwise -> putStrLn $ "Unknown file type: " ++ last ps++multiMain :: [(String, Diagram Cairo R2)] -> IO ()+multiMain ds = do+ prog <- getProgName+ opts <- cmdArgs (diagramOpts prog True)+ case selection opts of+ Nothing -> putStrLn "No diagram selected."+ Just sel -> case lookup sel ds of+ Nothing -> putStrLn $ "Unknown diagram: " ++ sel+ Just d -> chooseRender opts d++#ifdef CMDLINELOOP+waitForChange :: Maybe ClockTime -> DiagramOpts -> String -> [String] -> IO ()+waitForChange lastAttempt opts prog args = do+ hSetBuffering stdout NoBuffering+ go lastAttempt+ where go lastAtt = do+ threadDelay (1000000 * interval opts)+ -- putStrLn $ "Checking... (last attempt = " ++ show lastAttempt ++ ")"+ (newBin, newAttempt) <- recompile lastAtt prog (src opts)+ if newBin+ then executeFile prog False args Nothing+ else go $ getFirst (First newAttempt <> First lastAtt)++-- | @recompile t prog@ attempts to recompile @prog@, assuming the+-- last attempt was made at time @t@. If @t@ is @Nothing@ assume+-- the last attempt time is the same as the modification time of the+-- binary. If the source file modification time is later than the+-- last attempt time, then attempt to recompile, and return the time+-- of this attempt. Otherwise (if nothing has changed since the+-- last attempt), return @Nothing@. Also return a Bool saying+-- whether a successful recompilation happened.+recompile :: Maybe ClockTime -> String -> Maybe String -> IO (Bool, Maybe ClockTime)+recompile lastAttempt prog mSrc = do+ let errFile = prog ++ ".errors"+ srcFile = fromMaybe (prog ++ ".hs") mSrc+ binT <- maybe (getModTime prog) (return . Just) lastAttempt+ srcT <- getModTime srcFile+ if (srcT > binT)+ then do+ putStr "Recompiling..."+ status <- bracket (openFile errFile WriteMode) hClose $ \h ->+ waitForProcess =<< runProcess "ghc" ["--make", srcFile]+ Nothing Nothing Nothing Nothing (Just h)++ if (status /= ExitSuccess)+ then putStrLn "" >> putStrLn (replicate 75 '-') >> readFile errFile >>= putStr+ else putStrLn "done."++ curTime <- getClockTime+ return (status == ExitSuccess, Just curTime)++ else return (False, Nothing)++ where getModTime f = catch (Just <$> getModificationTime f)+ (\(SomeException _) -> return Nothing)+#endif