diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,36 @@ +Copyright 2011 diagrams-cairo team: + + Sam Griffin + Luite Stegeman + Kanchalai Suveepattananont + Ryan Yates + Brent Yorgey + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/diagrams-cairo.cabal b/diagrams-cairo.cabal new file mode 100644 --- /dev/null +++ b/diagrams-cairo.cabal @@ -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 diff --git a/example/Fractal.hs b/example/Fractal.hs new file mode 100644 --- /dev/null +++ b/example/Fractal.hs @@ -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) diff --git a/example/Hanoi.hs b/example/Hanoi.hs new file mode 100644 --- /dev/null +++ b/example/Hanoi.hs @@ -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) diff --git a/example/golden.hs b/example/golden.hs new file mode 100644 --- /dev/null +++ b/example/golden.hs @@ -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 diff --git a/example/gray.hs b/example/gray.hs new file mode 100644 --- /dev/null +++ b/example/gray.hs @@ -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) diff --git a/example/hslogo.hs b/example/hslogo.hs new file mode 100644 --- /dev/null +++ b/example/hslogo.hs @@ -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 diff --git a/example/paradox.hs b/example/paradox.hs new file mode 100644 --- /dev/null +++ b/example/paradox.hs @@ -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) diff --git a/example/tic-tac-toe/Maps.hs b/example/tic-tac-toe/Maps.hs new file mode 100644 --- /dev/null +++ b/example/tic-tac-toe/Maps.hs @@ -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) diff --git a/example/tic-tac-toe/Solve.hs b/example/tic-tac-toe/Solve.hs new file mode 100644 --- /dev/null +++ b/example/tic-tac-toe/Solve.hs @@ -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] ] + ] diff --git a/example/triangular-numbers.hs b/example/triangular-numbers.hs new file mode 100644 --- /dev/null +++ b/example/triangular-numbers.hs @@ -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 + ]) diff --git a/src/Diagrams/Backend/Cairo.hs b/src/Diagrams/Backend/Cairo.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Cairo.hs @@ -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 diff --git a/src/Diagrams/Backend/Cairo/CmdLine.hs b/src/Diagrams/Backend/Cairo/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Cairo/CmdLine.hs @@ -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