packages feed

wumpus-microprint (empty) → 0.1.1

raw patch · 9 files changed

+512/−0 lines, 9 filesdep +basedep +monadLibdep +vector-spacesetup-changed

Dependencies added: base, monadLib, vector-space, wumpus-basic, wumpus-core

Files

+ CHANGES view
@@ -0,0 +1,6 @@++0.1.0 to 0.1.1:++  * Added missing LICENSE file to the Cabal file.++  * Added this CHANGES file.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2008 Stephen Peter Tetley++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 AUTHORS ``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.
+ Setup.hs view
@@ -0,0 +1,29 @@+#!/usr/bin/env runhaskell++import Distribution.Simple+import Distribution.Simple.Setup ( SDistFlags )+import Distribution.PackageDescription ( HookedBuildInfo, emptyHookedBuildInfo )+++main = defaultMainWithHooks sdist_warning_hooks++sdist_warning_hooks :: UserHooks+sdist_warning_hooks = simpleUserHooks { preSDist = sdistVersionWarning }+++sdistVersionWarning :: Args -> SDistFlags -> IO HookedBuildInfo+sdistVersionWarning _ _ = +    mapM_ putStrLn msg >> printVersionNumberFile >> return emptyHookedBuildInfo+  where+    msg = [ "-------------------------------------------------------"+          , "-------------------------------------------------------"+          , ""+          , "WARNING - is Wumpus.MicroPrint.VersionNumber correct?"+          , ""+          , "-------------------------------------------------------"+          , "-------------------------------------------------------"+          ]++printVersionNumberFile :: IO ()+printVersionNumberFile = +  readFile "src/Wumpus/MicroPrint/VersionNumber.hs" >>= putStrLn
+ demo/Demo01.hs view
@@ -0,0 +1,49 @@+{-# OPTIONS -Wall #-}++-- Read this file a make a microprint of it...++module Demo01 where++import Wumpus.MicroPrint++import Wumpus.Core+import Wumpus.Basic.SVGColours++import Data.Maybe+import System.Directory++main :: IO ()+main = do +    { createDirectoryIfMissing True "./out/"+    ; micro1 <- filePic+    ; let pic1 = fromMaybe errK $ renderMicroPrint cfg1 (prefix micro1)+    ; writeEPS_latin1 "./out/mp01.eps" pic1+    ; writeSVG_latin1 "./out/mp01.svg" pic1+    }+  where+    prefix mp = setRGB lightSlateGrey >> mp++errK :: a+errK = error "no picture"++filePic :: IO (MicroPrint ())+filePic = do+  xs <- readFile "Demo01.hs"+  return $ foldr (\a acc -> drawChar a >> acc) (return ()) xs++drawChar :: Char -> MicroPrint ()+drawChar '\n' = linebreak+drawChar '\t' = space >> space >> space >> space+drawChar ' '  = space+drawChar _    = char+++cfg1 :: MP_config+cfg1 = MP_config +       { char_height    = 12.0+       , char_width     = 8.0+       , line_spacing   = 3.0+       , drawF          = greekF+       }+ +
+ src/Wumpus/MicroPrint.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.MicroPrint+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- MicroPrints+--+--------------------------------------------------------------------------------++module Wumpus.MicroPrint+  (++  -- * Re-export all MicroPrint.Render        +    module Wumpus.MicroPrint.Render++  -- * Top level rendering function+  , renderMicroPrint++  -- * Re-export some from MicroPrint.DrawMonad+  , MicroPrint+  , Tile(..)+  , Height+  , linebreak+  , setRGB+  , char+  , space++  ) where++import Wumpus.Core++import Wumpus.MicroPrint.DrawMonad+import Wumpus.MicroPrint.Render++++-- | Build a picture from a MicroPrint.+--+renderMicroPrint :: MP_config -> MicroPrint a -> Maybe DPicture+renderMicroPrint cfg mf = drawMicroPrint cfg $ execMicroPrint mf
+ src/Wumpus/MicroPrint/DrawMonad.hs view
@@ -0,0 +1,119 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.MicroPrint.DrawMonad+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- MicroPrints drawing monad +--+--------------------------------------------------------------------------------++module Wumpus.MicroPrint.DrawMonad+  (++    MicroPrint+  , runMicroPrint+  , execMicroPrint++  , Tile(..)+  , Height+  , linebreak+  , setRGB+  , char+  , space++  ) where++import Wumpus.Core+import Wumpus.Core.Colour ( black )++import Wumpus.Basic.Utils.HList++import Control.Monad++data Tile = LineBreak | Space Int | Word DRGB Int++-- Interim version without colour annotation...+data TileState = Start | S0 Int | W0 Int++++type Text       = H Tile+type Trace      = Text+type Height     = Int+type State      = (TileState, DRGB, Height)++-- | A /microprint/ is really a monad in disguise...+--+newtype MicroPrint a = MicroPrint { +          getMicroPrint :: Trace -> State -> (a,Trace,State) }++instance Functor MicroPrint where+  fmap f m = MicroPrint $ \w s -> +                let (a,w',s') = getMicroPrint m w s in (f a,w',s')++instance Monad MicroPrint where+  return a = MicroPrint $ \w s -> (a,w,s)+  m >>= k  = MicroPrint $ \w s -> let (a,w',s') = getMicroPrint m w s +                                  in (getMicroPrint . k) a w' s'+++runMicroPrint :: MicroPrint a -> (a,[Tile],Height)+runMicroPrint m = post $ getMicroPrint m emptyH (Start,black,1)+  where+    post (a,f,(W0 n, rgb, h)) = (a, toListH $ f `snocH` (Word rgb n), h)+    post (a,f,(_, _, h))      = (a, f [], h)++execMicroPrint :: MicroPrint a -> ([Tile],Height)+execMicroPrint = post . runMicroPrint+  where post (_,xs,h) = (xs,h)++enqueueTile :: MicroPrint ()+enqueueTile = MicroPrint $ \w (opt,rgb,h) -> +    let tileF = step rgb opt in ((), tileF w, (Start, rgb,h))+  where+    step _   Start  = id+    step _   (S0 n) = (\f -> f `snocH` (Space n))+    step rgb (W0 n) = (\f -> f `snocH` (Word rgb n))+++linebreak :: MicroPrint ()+linebreak = enqueueTile >> next+  where+    next = MicroPrint $ +             \w (opt,rgb,h) -> ((),w `snocH` LineBreak, (opt,rgb,h+1))++-- Note - it is permissible to change colour mid-word.+-- But this is the same as having a no-space break.+--+setRGB :: DRGB -> MicroPrint ()+setRGB rgb = enqueueTile >> next+  where+    -- tip will always be Start here...+    next = MicroPrint $ \w (tip,_,h) -> ((),w,(tip,rgb,h))++char :: MicroPrint ()+char = MicroPrint $ \w (tip,rgb,h) ->+    let (f,tip') = addChar tip in ((),f w,(tip',rgb,h))+  where+    addChar Start  = (id, W0 1)+    addChar (W0 n) = (id, W0 $ n+1)+    addChar (S0 n) = (\f -> f `snocH` (Space n), W0 1)+++space :: MicroPrint ()+space = MicroPrint $ \w (tip,rgb,h) ->+    let (f,tip') = addSpace tip rgb in ((),f w,(tip',rgb,h))+  where+    addSpace Start  _   = (id, S0 1)+    addSpace (W0 n) rgb = (\f -> f `snocH` (Word rgb n), S0 1)+    addSpace (S0 n) _   = (id, S0 $ n+1)++ +
+ src/Wumpus/MicroPrint/Render.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.MicroPrint.Render+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Render+--+--------------------------------------------------------------------------------++module Wumpus.MicroPrint.Render+  (+  +    Graphic+  , DGraphic+  , MP_config(..)+  , greekF++  , drawMicroPrint++  ) where++import Wumpus.Core+import Wumpus.Basic.Monads.TraceMonad+import Wumpus.Basic.Monads.TurtleMonad+import Wumpus.Basic.Utils.HList++import Wumpus.MicroPrint.DrawMonad ( Tile(..), Height ) ++import Data.AffineSpace                 -- package: vector-space+import MonadLib                         -- package: monadLib++import Control.Applicative+import Control.Monad++-- | Note - this representation allows for zero, one or more+-- Primitives to be collected together.+--+type Graphic u = H (Primitive u)++type DGraphic  = Graphic Double++type GraphicF u = Point2 u -> Graphic u++type DGraphicF = GraphicF Double ++++data MP_config = MP_config +       { char_height    :: Double+       , char_width     :: Double+       , line_spacing   :: Double +       , drawF          :: Double -> Double -> DRGB -> DGraphicF+       }++greekF :: Double -> Double -> DRGB -> DGraphicF+greekF w h rgb = filledRectangle rgb w h ++++newtype RenderMonad a = RM { getRM :: ReaderT MP_config+                                    ( TraceT  DPrimitive Turtle)  a }++instance Functor RenderMonad where+  fmap f = RM . fmap f . getRM++instance Monad RenderMonad where+  return a = RM $ return a+  m >>= k  = RM $ getRM m >>= getRM . k++instance Applicative RenderMonad where+  pure  = return+  (<*>) = ap++instance TraceM RenderMonad DPrimitive where+  trace  h = RM $ lift $ trace h+  trace1 i = RM $ lift $ trace1 i++instance ReaderM RenderMonad MP_config where+  ask      = RM $ ask++instance TurtleM RenderMonad where+  getLoc   = RM $ lift $ lift $ getLoc+  setLoc c = RM $ lift $ lift $ setLoc c+++drawMicroPrint :: MP_config -> ([Tile],Height) -> Maybe DPicture+drawMicroPrint cfg (xs,h) = +    let (_,hf) = runRender cfg (moveUpN h >> interpret xs) in post $ hf []+  where+    post [] = Nothing+    post ps = Just $ frameMulti $ ps++runRender :: MP_config -> RenderMonad a -> (a, DGraphic)+runRender cfg m = +    post $ runTurtle $ runTraceT $ runReaderT cfg $ getRM $ m+  where+    post ((a,w), _) = (a,w)++interpret :: [Tile] -> RenderMonad ()+interpret = mapM_ interp1++interp1 :: Tile -> RenderMonad ()+interp1 LineBreak     = nextLine+interp1 (Space    i)  = moveRightN i+interp1 (Word rgb i)  = do+    w  <- scaleWidth i +    h  <- asks char_height+    pt <- scaleCurrentCoord+    dF <- asks drawF+    trace (dF w h rgb pt)+    moveRightN i+   +moveRightN :: Int -> RenderMonad ()+moveRightN i = setsLoc_ (\(Coord x y) -> Coord (x+i) y )++moveUpN :: Int -> RenderMonad ()+moveUpN i = setsLoc_ (\(Coord x y) -> Coord x (y+i) )++scaleCurrentCoord :: RenderMonad DPoint2+scaleCurrentCoord = +    fn <$> getLoc <*> asks char_width <*> asks char_height <*> asks line_spacing+  where+    fn (Coord x y) cw ch sp = P2 (cw * fromIntegral x) ((ch+sp) * fromIntegral y)++scaleWidth :: Int -> RenderMonad Double+scaleWidth i = (\cw -> cw * fromIntegral i) <$> asks char_width+++--------------------------------------------------------------------------------++filledRectangle :: (Num u, Ord u, Fill t) +                => t -> u -> u -> GraphicF u+filledRectangle t w h bl = wrapH $ fill t $ rectangle w h bl++rectangle :: Num u => u -> u -> Point2 u -> Path u+rectangle w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]+  where+    br = bl .+^ hvec w+    tr = br .+^ vvec h+    tl = bl .+^ vvec h
+ src/Wumpus/MicroPrint/VersionNumber.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.MicroPrint.VersionNumber+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC with TypeFamilies and more+--+-- Version number+--+--------------------------------------------------------------------------------++module Wumpus.MicroPrint.VersionNumber+  ( +    wumpus_microprint_version++  ) where+++wumpus_microprint_version :: (Int,Int,Int)+wumpus_microprint_version = (0,1,1)
+ wumpus-microprint.cabal view
@@ -0,0 +1,58 @@+name:             wumpus-microprint+version:          0.1.1+license:          BSD3+license-file:     LICENSE+copyright:        Stephen Tetley <stephen.tetley@gmail.com>+maintainer:       Stephen Tetley <stephen.tetley@gmail.com>+homepage:         http://code.google.com/p/copperbox/+category:         Graphics+synopsis:         Microprints - "greek-text" pictures.+description:+  .+  A library to produce /microprints/ [1] sometimes known as +  \"greek-text\". +  .+  Note this library only provides the graphically half of the +  functionality needed to make microprints. There is no support +  for tokenizing input files, and at the moment it is really +  just a test bed for Wumpus.+  .+  \[1\] <http://scg.unibe.ch/archive/papers/Robb05b-microprintsESUG.pdf>+  .+  .+build-type:         Simple+stability:          highly unstable+cabal-version:      >= 1.2++extra-source-files:+  CHANGES,+  LICENSE,+  demo/Demo01.hs+  +library+  hs-source-dirs:     src+  build-depends:      base              < 5, +                      vector-space      >= 0.6,+                      monadLib          >= 3.6,+                      wumpus-core       >= 0.20.0,+                      wumpus-basic      >= 0.1.0++  +  exposed-modules:+    Wumpus.MicroPrint,+    Wumpus.MicroPrint.DrawMonad,+    Wumpus.MicroPrint.Render,+    Wumpus.MicroPrint.VersionNumber++  other-modules:++  extensions:+    ++  ghc-options:+  +  includes: +  ++  +