packages feed

hoodle-types (empty) → 0.1

raw patch · 12 files changed

+1328/−0 lines, 12 filesdep +TypeComposedep +basedep +bytestringsetup-changed

Dependencies added: TypeCompose, base, bytestring, cereal, containers, lens, strict

Files

+ CHANGES view
@@ -0,0 +1,9 @@+0.1: 18 Dec 2011+   * First public release +0.2: 25 Dec 2011+   * double buffer support+0.3: 15 Jan 2012 +   * ZipperSelect support +0.4: 12 Feb 2012 +   * Variable width stroke support+
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2011, Ian-Woo Kim. 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.lhs view
@@ -0,0 +1,10 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> import Distribution.PackageDescription+> --import System.Process+> main = defaultMain+> --main = defaultMainWithHooks testUserHooks+> --testUserHooks = simpleUserHooks { +>  --   preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo+>   --  }
+ hoodle-types.cabal view
@@ -0,0 +1,43 @@+Name:		hoodle-types+Version:	0.1+Synopsis:	Data types for programs for hoodle file format+Description: 	Hoodle file format data type including generic interface+License: 	BSD3+License-file:	LICENSE+Author:		Ian-Woo Kim+Maintainer: 	Ian-Woo Kim <ianwookim@gmail.com>+Category:       Data+Build-Type: 	Simple+Cabal-Version:  >= 1.8+data-files:     CHANGES+Source-repository head+  type: git+  location: https://www.github.com/wavewave/hhoodle+++Library+  hs-source-dirs: src+  ghc-options: 	-Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans+  ghc-prof-options: -caf-all -auto-all+  Build-Depends: +                   base == 4.*, +                   bytestring == 0.9.*, +                   strict == 0.3.*, +                   containers == 0.4.*, +                   lens >= 2.4 && < 2.7,+                   TypeCompose == 0.9.*, +                   cereal == 0.3.* +  Exposed-Modules: +                   Data.Hoodle.BBox+                   Data.Hoodle.Generic+                   Data.Hoodle.Generic.Simple+                   Data.Hoodle.Predefined +                   Data.Hoodle.Simple+                   Data.Hoodle.Select+                   Data.Hoodle.Util+                   Data.Hoodle.Zipper ++  Other-Modules: ++ +
+ src/Data/Hoodle/BBox.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE TypeFamilies, StandaloneDeriving, RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.BBox +-- Copyright   : (c) 2011, 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Data.Hoodle.BBox +( BBox (..) +, BBoxable (..) +, StrokeBBox (..)+-- , strkbbx_strk+-- , strkbbx_bbx+, mkStrokeBBox+, ImageBBox (..)+-- , imgbbx_img+-- , imgbbx_bbx+, mkImageBBox+, mkbbox+, mkbboxF+, bboxFromStroke+, bboxFromImage+, dimToBBox+, bboxToDim+, xformBBox+, inflate+, moveBBoxToOrigin+, moveBBoxByOffset+, moveBBoxULCornerTo+, intersectBBox+, unionBBox+, ULMaybe (..) +, IntersectBBox (..) +, UnionBBox (..)+, Maybeable (..)+, bbox4All+) where++import           Control.Applicative +import           Control.Monad+import qualified Data.Foldable as F+import           Data.Monoid+import           Data.Serialize+import           Data.Strict.Tuple +-- from this package+import           Data.Hoodle.Simple+import           Data.Hoodle.Util+-- +import Prelude hiding (fst,snd)+import qualified Prelude as Prelude (fst,snd)++++-- | bounding box type +data BBox = BBox { bbox_upperleft :: (Double,Double) +                 , bbox_lowerright :: (Double,Double) } +          deriving (Show,Eq,Ord)++-- | +instance Serialize BBox where+    put BBox{..} = put bbox_upperleft >> put bbox_lowerright  +    get = liftM2 BBox get get +++class BBoxable a where +  getBBox :: a -> BBox++-- | +data StrokeBBox = StrokeBBox { strkbbx_strk :: Stroke +                             , strkbbx_bbx :: BBox } +                deriving (Show,Eq,Ord)+  +instance BBoxable StrokeBBox where+  getBBox = strkbbx_bbx+                         +-- |+instance Serialize StrokeBBox where+  put StrokeBBox{..} = put strkbbx_strk >> put strkbbx_bbx+  get = liftM2 StrokeBBox get get+  +-- | smart constructor for StrokeBBox +mkStrokeBBox :: Stroke -> StrokeBBox+mkStrokeBBox strk = +  StrokeBBox { strkbbx_strk = strk+             , strkbbx_bbx = bboxFromStroke strk+             } ++-- | +data ImageBBox = ImageBBox { imgbbx_img :: Image +                           , imgbbx_bbx :: BBox } +                deriving (Show,Eq,Ord)+  +instance BBoxable ImageBBox where+  getBBox = imgbbx_bbx++-- |+instance Serialize ImageBBox where+  put ImageBBox{..} = put imgbbx_img >> put imgbbx_bbx+  get = ImageBBox <$> get <*> get+  +-- | smart constructor for ImageBBox +mkImageBBox :: Image -> ImageBBox+mkImageBBox img = +  ImageBBox { imgbbx_img = img+            , imgbbx_bbx = bboxFromImage img+            } +++-- |+mkbbox :: [Pair Double Double] -> BBox +mkbbox lst = let xs = map fst lst +                 ys = map snd lst+             in  BBox { bbox_upperleft = (minimum xs, minimum ys)+                      , bbox_lowerright = (maximum xs, maximum ys) } +                 +-- |                 +mkbboxF :: (F.Foldable m, Functor m) => m (Double,Double) -> BBox +mkbboxF lst = +  let xs = fmap Prelude.fst lst  +      ys = fmap Prelude.snd lst +  in BBox{bbox_upperleft=(F.minimum xs, F.minimum ys)+         ,bbox_lowerright=(F.maximum xs, F.maximum ys)}++-- |+bboxFromStroke :: Stroke -> BBox +bboxFromStroke (Stroke _ _ w dat) = inflate (mkbbox dat) w+bboxFromStroke (VWStroke _ _ dat) = +  let dat' = map ((,) <$> fst3 <*> snd3) dat +      widthmax = F.maximum (map trd3 dat)+  in inflate (mkbboxF dat') widthmax++-- |+dimToBBox :: Dimension -> BBox +dimToBBox (Dim w h) = BBox (0,0) (w,h)++-- |+-- |+bboxToDim :: BBox -> Dimension+bboxToDim (BBox (x1,y1) (x2,y2)) = Dim (x2-x1) (y2-y1)+++-- | +bboxFromImage :: Image -> BBox +bboxFromImage (Image _ (x,y) d) = moveBBoxULCornerTo (x,y) (dimToBBox d)    +++-- | general transform BBox         +xformBBox :: ((Double,Double) -> (Double,Double)) -> BBox -> BBox +xformBBox f (BBox c1 c2) = BBox (f c1) (f c2)++-- | inflate bbox by amount r +inflate :: BBox -> Double -> BBox +inflate (BBox (x1,y1) (x2,y2)) r = BBox (x1-r,y1-r) (x2+r,y2+r)++-- | +moveBBoxToOrigin :: BBox -> BBox +moveBBoxToOrigin (BBox (x0,y0) (x1,y1)) = BBox (0,0) (x1-x0,y1-y0)++-- |+moveBBoxByOffset :: (Double,Double) -> BBox -> BBox +moveBBoxByOffset (xoff,yoff) (BBox (x0,y0) (x1,y1)) = BBox (x0+xoff,y0+yoff) (x1+xoff,y1+yoff)++-- |+moveBBoxULCornerTo :: (Double,Double) -> BBox -> BBox +moveBBoxULCornerTo (x,y) b@(BBox (x0,y0) _) = moveBBoxByOffset (x-x0,y-y0) b ++-- |+intersectBBox :: BBox -> BBox -> Maybe BBox+intersectBBox (BBox (x1,y1) (x2,y2)) (BBox (x3,y3) (x4,y4)) = do +  guard $ (x1 <= x3 && x3 <= x2) || (x3 <= x1 && x1 <= x4 ) +  guard $ (y1 <= y3 && y3 <= y2) || (y3 <= y1 && y1 <= y4 )+  let x5 = if x1 <= x3 then x3 else x1 +      y5 = if y1 <= y3 then y3 else y1 +      x6 = min x2 x4 +      y6 = min y2 y4+  return (BBox (x5,y5) (x6,y6))+  +-- |  +unionBBox :: BBox -> BBox -> BBox+unionBBox (BBox (x1,y1) (x2,y2)) (BBox (x3,y3) (x4,y4)) = +  let x5 = if x1 < x3 then x1 else x3+      y5 = if y1 < y3 then y1 else y3+      x6 = if x2 < x4 then x4 else x2+      y6 = if y2 < y4 then y4 else y2+  in BBox (x5,y5) (x6,y6)+  +-- |+data ULMaybe a = Bottom | Middle a | Top      ++deriving instance Show a => Show (ULMaybe a)++deriving instance Eq a => Eq (ULMaybe a)+                                     +-- |+newtype IntersectBBox = Intersect { unIntersect :: ULMaybe BBox } +                        deriving (Show,Eq)++-- |+newtype UnionBBox = Union { unUnion :: ULMaybe BBox }+                    deriving (Show,Eq)+     +instance Monoid (IntersectBBox) where +  (Intersect Bottom) `mappend` _ = Intersect Bottom+  _ `mappend` (Intersect Bottom) = Intersect Bottom +  (Intersect Top) `mappend` x = x +  x `mappend` (Intersect Top) = x +  (Intersect (Middle x)) `mappend` (Intersect (Middle y)) = +    maybe (Intersect Bottom) (Intersect . Middle) (x `intersectBBox` y)+  mempty = Intersect Top +  +instance Monoid (UnionBBox) where+  (Union Bottom) `mappend` x = x +  x `mappend` (Union Bottom) = x+  (Union Top) `mappend` _ = Union Top+  _ `mappend` (Union Top) = Union Top +  (Union (Middle x)) `mappend` (Union (Middle y)) = Union (Middle (x `unionBBox` y))+  mempty = Union Bottom+  +-- |+class Maybeable a where+  type ElemType a :: *+  toMaybe :: a -> Maybe (ElemType a) +  fromMaybe :: Maybe (ElemType a) -> a +  +instance Maybeable IntersectBBox where+  type ElemType IntersectBBox = BBox+  toMaybe (Intersect Bottom) = Nothing  +  toMaybe (Intersect Top) = Nothing +  toMaybe (Intersect (Middle x)) = Just x +  fromMaybe Nothing = Intersect Top +  fromMaybe (Just x) = Intersect (Middle x)+  +instance Maybeable UnionBBox where+  type ElemType UnionBBox = BBox+  toMaybe (Union Bottom) = Nothing +  toMaybe (Union Top) = Nothing +  toMaybe (Union (Middle x)) = Just x +  fromMaybe Nothing = Union Top +  fromMaybe (Just x) = Union (Middle x)+++-- | +bbox4All :: (F.Foldable t, Functor t, BBoxable a) => t a -> ULMaybe BBox +bbox4All = unUnion . F.fold . fmap (Union . Middle . getBBox)
+ src/Data/Hoodle/Generic.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.Generic +-- Copyright   : (c) 2011, 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Data.Hoodle.Generic where++-- from other packages+-- import Control.Applicative+import Control.Category+import Control.Lens +import Data.ByteString hiding (map,zip)+import Data.Foldable+import Data.Functor+import qualified Data.IntMap as IM --  hiding (map)+import qualified Data.Sequence as Seq +-- from this package+import Data.Hoodle.Simple+-- +import Prelude hiding ((.),id)++-- | Generic Hoodle data having generic pages+data GHoodle cntnr pg = GHoodle +                        { ghoodle_ttl :: ByteString +                        , ghoodle_pgs :: cntnr pg }  ++-- | Generic page data having dimension, generic background+--   and generic layers+data GPage bkg cntnr lyr = GPage +                           { gpage_dim :: Dimension +                           , gpage_bkg :: bkg +                           , gpage_lyrs :: cntnr lyr }  ++-- -- | Generic layer data having generic items +-- data GLayer cntnr itm = GLayer { glayer_itms :: cntnr itm } +            +-- | Generic buffered layer having generic items+data GLayer buf cntnr itm = GLayer +                             { glayer_buf :: buf +                             -- , glayer_strks :: cntnr strk +                             , glayer_itms :: cntnr itm +                             } +                       +{-                          +-- |+instance (Functor s) => Functor (GLayer s) where+  fmap f (GLayer bstrs) = GLayer (fmap f strs)+-}++-- | +instance (Functor cntnr) => Functor (GLayer buf cntnr) where+  fmap f (GLayer buf itms) = GLayer buf (fmap f itms) +  +-- | +instance (Functor cntnr) => Functor (GPage bkg cntnr) where+  fmap f (GPage dim bkg lyrs) = GPage dim bkg (fmap f lyrs)+  +-- | +instance (Functor cntnr) => Functor (GHoodle cntnr) where+  fmap f (GHoodle ttl pgs) = GHoodle ttl (fmap f pgs)++------------------------------+-- lenses for Generic types --+------------------------------+++-- |+gtitle :: Simple Lens (GHoodle cntnr pg) ByteString+gtitle = lens ghoodle_ttl (\f a -> f { ghoodle_ttl = a } )++-- |+gpages :: Simple Lens (GHoodle cntnr pg) (cntnr pg)+gpages = lens ghoodle_pgs (\f a -> f { ghoodle_pgs = a } )++-- |+gdimension :: Simple Lens (GPage bkg cntnr pg) Dimension +gdimension = lens gpage_dim (\f a -> f { gpage_dim = a } )++-- |+gbackground :: Simple Lens (GPage bkg cntnr lyr) bkg +gbackground = lens gpage_bkg (\f a -> f { gpage_bkg = a } ) ++-- |+glayers :: Simple Lens (GPage bkg cntnr lyr) (cntnr lyr)+glayers = lens gpage_lyrs (\f a -> f { gpage_lyrs = a } ) +++-- |+gitems :: Simple Lens (GLayer buf cntnr itm) (cntnr itm)+gitems = lens glayer_itms (\f a -> f { glayer_itms = a } )+++{-+-- |+gstrokes :: Simple Lens (GLayer buf cntnr strk) (cntnr strk)+gstrokes = lens glayer_strks (\f a -> f { glayer_strks = a } )+-}++-- |+gbuffer :: Simple Lens (GLayer buf cntnr itm) buf +gbuffer = lens glayer_buf (\f a -> f { glayer_buf = a } )++++-- |+class (Foldable s) => Listable s where  +  fromList :: [a] -> s a +--   toList :: s a -> [a]+  +-- |+instance Listable [] where+  fromList = id +--   toList = id +  +-- | +instance Listable IM.IntMap where +  fromList = IM.fromList . zip [0..] +--   toList = Data.IntMap.elems +  +-- | +instance Listable Seq.Seq where+  fromList = Seq.fromList ++-- |+emptyGHoodle :: (Listable m) => GHoodle m a+emptyGHoodle = GHoodle "" (fromList [])++-- | +emptyGPage :: (Listable cntnr) => Dimension -> bkg -> GPage bkg cntnr a +emptyGPage dim bkg = GPage dim bkg (fromList [])+  ++{-+-- |+class GBackgroundable b where+  gFromBackground :: Background -> b +  gToBackground :: b -> Background+  +-- | +instance GBackgroundable Background where  +  gFromBackground = id +  gToBackground = id++-- |+fromLayer :: (GStrokeable a, GListable s) => Layer -> GLayer s a +fromLayer = GLayer . gFromList . fmap gFromStroke . layer_strokes ++-- |+fromPage :: (GStrokeable a, GBackgroundable b, +             GListable s, GListable s') => +            Page -> GPage b s' (GLayer s a)  +fromPage p = let bkg = gFromBackground $ page_bkg p +                 dim = page_dim p +                 ls =  gFromList . fmap fromLayer . page_layers $ p +             in  GPage dim bkg ls ++-- |+class SListable m where+  chgStreamToList :: (GListable s) => m s a -> m [] a +  +-- |+instance SListable GLayer where+  chgStreamToList (GLayer xs) = GLayer (gToList xs)++-- | +instance SListable (GPage b) where+  chgStreamToList (GPage d b ls) = GPage d b (gToList ls)+  +-- |+instance SListable GHoodle where+  chgStreamToList (GHoodle t ps) = GHoodle t (gToList ps)+  ++-- |+toLayer :: (GStrokeable a, GListable s) => GLayer s a -> Layer+toLayer = layerFromTLayerSimple . fmap gToStroke . chgStreamToList ++-- |+toNoBufferLayer :: GLayerBuf b s a -> GLayer s a +toNoBufferLayer (GLayerBuf _b s) = GLayer s ++-- | +toPage :: (GStrokeable a, GBackgroundable b, GListable s, GListable s', Functor s') => +          (b->Background) -> GPage b s' (GLayer s a) -> Page+toPage f = pageFromTPageSimple . bkgchange f . chgStreamToList . fmap (fmap gToStroke . chgStreamToList) ++-- | +toPageFromBuf :: (GStrokeable a, GBackgroundable b, GListable s, GListable s', Functor s') => +              (b->Background) -> GPage b s' (GLayerBuf buf s a) -> Page+toPageFromBuf f = pageFromTPageSimple . bkgchange f . chgStreamToList . fmap (fmap gToStroke . chgStreamToList . toNoBufferLayer) ++-- | +bkgchange :: (b -> b') -> GPage b s a -> GPage b' s a +bkgchange f p = p { gbackground = f (gbackground p) } +++-- | +mkTPageSimpleFromPage :: Page -> TPageSimple +mkTPageSimpleFromPage = GPage <$> page_dim <*> page_bkg <*> map mkTLayerSimpleFromLayer . page_layers ++-- | +mkTHoodleSimpleFromHoodle :: Hoodle -> THoodleSimple +mkTHoodleSimpleFromHoodle = +  GHoodle <$> hoodle_title +          <*> map mkTPageSimpleFromPage . hoodle_pages++-- | +layerFromTLayerSimple :: TLayerSimple -> Layer+layerFromTLayerSimple = Layer <$> gstrokes++-- | +pageFromTPageSimple :: TPageSimple -> Page+pageFromTPageSimple = Page <$> gdimension <*> gbackground <*> map layerFromTLayerSimple . glayers++-- | +hoodleFromTHoodleSimple :: THoodleSimple -> Hoodle +hoodleFromTHoodleSimple = Hoodle <$> gtitle <*> map pageFromTPageSimple . gpages +++---- ++-- |+emptyPageFromOldPage :: (GListable s) => GPage b s a -> GPage b s a+emptyPageFromOldPage = GPage +                       <$> (^.g_dimension) +                       <*> (^.g_background) +                       <*> pure (gFromList []) +--  (get g_dimension p) (get g_background p) (gFromList [] )++----++-- | +printLayerStructureInPage :: (GListable s) => +                              GPage b s (GLayerBuf buf [] a) -> IO () +printLayerStructureInPage page = do +  let lyrs = page^.g_layers +      lst = fmap (Prelude.length . (^.g_bstrokes)) (gToList lyrs)+  (Prelude.putStrLn . ("num of layers = "++) . show . Prelude.length . gToList ) lyrs +  Prelude.putStrLn $ "layer strokes = " ++ show lst +-}++{-+-- | +type TLayerSimple = GLayer [] Stroke ++-- | +type TPageSimple = GPage Background [] TLayerSimple ++-- |+type THoodleSimple = GHoodle [] TPageSimple +-}++{-+-- |+class GStrokeable a where+  gFromStroke :: Stroke -> a +  gToStroke :: a -> Stroke +  +-- |+instance GStrokeable Stroke where+  gFromStroke = id+  gToStroke = id +-}++{-+-- | +class GCast a b where +  gcast :: a -> b +-}
+ src/Data/Hoodle/Generic/Simple.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TypeFamilies, TypeOperators, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.Generic.Simple +-- Copyright   : (c) 2011, 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- Simple Hoodle Type in Generic parameterized type+-- +-----------------------------------------------------------------------------++module Data.Hoodle.Generic.Simple where++import Control.Applicative+import Control.Lens +-- from this package+import Data.Hoodle.Generic+import Data.Hoodle.Simple++-- | +type SLayer = GLayer () [] Item  -- Strokes ++-- | +type SPage = GPage Background [] SLayer ++-- |+type SHoodle = GHoodle [] SPage ++-- | smart constructor for SLayer +mkSLayer :: Layer -> SLayer+mkSLayer = GLayer () <$> view items -- strokes ++-- | smart constructor for SPage+mkSPage :: Page -> SPage +mkSPage = GPage +          <$> view dimension +          <*> view background +          <*> map mkSLayer . view layers  ++-- | smart constructor for SHoodle +mkSHoodle :: Hoodle -> SHoodle +mkSHoodle = GHoodle +            <$> view title +            <*> map mkSPage . view pages++-- | +slayer2Layer :: SLayer -> Layer +slayer2Layer (GLayer _ itms) = Layer itms ++-- | +spage2Page :: SPage -> Page +spage2Page (GPage dim bkg lyrs) = Page dim bkg (map slayer2Layer lyrs)++-- | +shoodle2Hoodle :: SHoodle -> Hoodle+shoodle2Hoodle (GHoodle ttl pgs) = Hoodle ttl (map spage2Page pgs)+
+ src/Data/Hoodle/Predefined.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.Predefined +-- Copyright   : (c) 2011, 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--++module Data.Hoodle.Predefined where++import qualified Data.Map as M+import qualified Data.ByteString.Char8 as B++import Text.Printf ++-- | ++predefinedPenShapeAspectXY :: (Double,Double)+predefinedPenShapeAspectXY = (cos (pi/6.0), sin (pi/6.0))++-- | ++hexToRGBA :: Integer -> (Double,Double,Double,Double) +hexToRGBA n = +  let r = n `div` (256*256*256)+      g = (n-r*256*256*256) `div` (256*256)+      b = (n-r*256*256*256-g*256*256) `div` 256 +      a = n-r*256*256*256-g*256*256-b*256  +  in  (fromIntegral r/255.0,fromIntegral g/255.0,fromIntegral b/255.0,fromIntegral a/255.0)++rgbaToHEX :: (Double,Double,Double,Double) -> String+rgbaToHEX (r,g,b,a) = +  let i :: Integer = round (255*a) + round (256*255*b) + round (256*256*255*g) + round (256*256*256*255*r) +  in printf "#%08x" i++predefined_highlighter_opacity :: Double +predefined_highlighter_opacity = 0.5++predefined_pencolor :: M.Map B.ByteString (Double,Double,Double,Double)+predefined_pencolor = +  M.fromList [ ("black"     , hexToRGBA 0x000000ff)+             , ("blue"      , hexToRGBA 0x3333ccff)+             , ("red"       , hexToRGBA 0xff0000ff)+             , ("green"     , hexToRGBA 0x008000ff)+             , ("gray"      , hexToRGBA 0x808080ff)+             , ("lightblue" , hexToRGBA 0x00c0ffff)+             , ("lightgreen", hexToRGBA 0x00ff00ff)+             , ("magenta"   , hexToRGBA 0xff00ffff)+             , ("orange"    , hexToRGBA 0xff8000ff)+             , ("yellow"    , hexToRGBA 0xffff00ff)+             , ("white"     , hexToRGBA 0xffffffff) ] ++{-+getPenColor :: B.ByteString -> Maybe (Double,Double,Double,Double) +getPenColor b | (not . B.null) b = +  case B.head b of +    '#' -> B.tail b +-}++predefined_bkgcolor :: M.Map B.ByteString (Double,Double,Double,Double)+predefined_bkgcolor = +  M.fromList [ (""      , hexToRGBA 0xffffffff) +             , ("blue"  , hexToRGBA 0xa0e8ffff)+             , ("pink"  , hexToRGBA 0xffc0d4ff)+             , ("green" , hexToRGBA 0x80ffc0ff)+             , ("orange", hexToRGBA 0xffc080ff)+             , ("yellow", hexToRGBA 0xffff80ff)+             , ("white" , hexToRGBA 0xffffffff) ]++predefined_veryfine :: Double+predefined_veryfine = 0.42 ++predefined_fine :: Double+predefined_fine = 0.85++predefined_medium :: Double+predefined_medium = 1.41 ++predefined_thick :: Double+predefined_thick = 2.26++predefined_verythick :: Double +predefined_verythick = 5.67++predefined_ultrathick :: Double +predefined_ultrathick = 15.41++---- for Highlighter++predefined_highlighter_veryfine :: Double+predefined_highlighter_veryfine = 2.83++predefined_highlighter_fine :: Double+predefined_highlighter_fine = 2.83++predefined_highlighter_medium :: Double+predefined_highlighter_medium = 8.50++predefined_highlighter_thick :: Double+predefined_highlighter_thick = 19.84++predefined_highlighter_verythick :: Double +predefined_highlighter_verythick = 19.84++predefined_highlighter_ultrathick :: Double +predefined_highlighter_ultrathick = 30.84+++---- for Eraser++predefined_eraser_veryfine :: Double+predefined_eraser_veryfine = 2.83++predefined_eraser_fine :: Double+predefined_eraser_fine = 2.83++predefined_eraser_medium :: Double+predefined_eraser_medium = 8.50++predefined_eraser_thick :: Double+predefined_eraser_thick = 19.84++predefined_eraser_verythick :: Double +predefined_eraser_verythick = 19.84++predefined_eraser_ultrathick :: Double +predefined_eraser_ultrathick = 30.84++++predefined_RULING_MARGIN_COLOR :: (Double,Double,Double,Double)+predefined_RULING_MARGIN_COLOR = hexToRGBA 0xff0080ff++predefined_RULING_COLOR :: (Double,Double,Double,Double)+predefined_RULING_COLOR = hexToRGBA 0x40a0ffff++predefined_RULING_THICKNESS :: Double+predefined_RULING_THICKNESS = 0.5++predefined_RULING_LEFTMARGIN :: Double+predefined_RULING_LEFTMARGIN = 72.0++predefined_RULING_TOPMARGIN :: Double+predefined_RULING_TOPMARGIN = 80.0++predefined_RULING_SPACING :: Double+predefined_RULING_SPACING = 24.0++predefined_RULING_BOTTOMMARGIN :: Double +predefined_RULING_BOTTOMMARGIN = predefined_RULING_SPACING++predefined_RULING_GRAPHSPACING :: Double+predefined_RULING_GRAPHSPACING = 14.17
+ src/Data/Hoodle/Select.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TypeFamilies, TypeOperators, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.Select +-- Copyright   : (c) 2011, 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Data.Hoodle.Select where++-- from other packages+import Control.Lens+import Data.ByteString +-- ++-- | +data GSelect a b = GSelect { gselect_ttl :: ByteString +                           , gselect_all :: a +                           , gselect_selected :: b+                           }+++-- |+gselTitle :: Simple Lens (GSelect a b) ByteString+gselTitle = lens gselect_ttl (\f a -> f {gselect_ttl = a})++-- |+gselAll :: Simple Lens (GSelect a b) a +gselAll = lens gselect_all (\f a -> f {gselect_all = a} )++-- |+gselSelected :: Simple Lens (GSelect a b) b+gselSelected = lens gselect_selected (\f a -> f {gselect_selected = a})++
+ src/Data/Hoodle/Simple.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE BangPatterns, OverloadedStrings,  TypeOperators, +             TypeFamilies, FlexibleContexts, RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.Simple +-- Copyright   : (c) 2011, 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+----------------------------------------------------------------------------- ++module Data.Hoodle.Simple where++-- from other packages+import           Control.Applicative +import           Control.Lens +import qualified Data.ByteString as S+import           Data.ByteString.Char8 hiding (map)+-- import           Data.Label+import qualified Data.Serialize as SE+import           Data.Strict.Tuple+-- from this package+import           Data.Hoodle.Util+-- +import Prelude hiding ((.),id,putStrLn,fst,snd,curry,uncurry)++-- | +type Title = S.ByteString++-- | wrapper of object embeddable in Layer+data Item = ItemStroke Stroke+          | ItemImage Image+          deriving (Show,Eq,Ord)+++-- | Pen stroke item +data Stroke = Stroke { stroke_tool  :: !S.ByteString+                     , stroke_color :: !S.ByteString+                     , stroke_width :: !Double+                     , stroke_data  :: ![Pair Double Double]+                     }+            | VWStroke { stroke_tool :: S.ByteString +                       , stroke_color :: S.ByteString +                       , stroke_vwdata :: [(Double,Double,Double)] +                       }+            deriving (Show,Eq,Ord)++-- | Image item +data Image = Image { img_src :: S.ByteString+                   , img_pos :: (Double,Double)+                   , img_dim :: !Dimension+                   } +             deriving (Show,Eq,Ord)++++-- | +instance SE.Serialize Stroke where+    put Stroke{..} = SE.putWord8 0 +                     >> SE.put stroke_tool +                     >> SE.put stroke_color+                     >> SE.put stroke_width+                     >> SE.put stroke_data+    put VWStroke{..} = SE.putWord8 1 +                       >> SE.put stroke_tool +                       >> SE.put stroke_color+                       >> SE.put stroke_vwdata+    get = do tag <- SE.getWord8  +             case tag of +               0 -> Stroke <$> SE.get <*> SE.get <*> SE.get <*> SE.get+               1 -> VWStroke <$> SE.get <*> SE.get <*> SE.get+               _ -> fail "err in Stroke parsing"+++-- | +instance SE.Serialize Image where+    put Image {..} = SE.put img_src+                     >> SE.put img_pos+                     >> SE.put img_dim+    get = Image <$> SE.get <*> SE.get <*> SE.get+++-- | +instance SE.Serialize Item where+    put (ItemStroke str) = SE.putWord8 0 +                           >> SE.put str +    put (ItemImage img) = SE.putWord8 1 +                          >> SE.put img+    get = do tag <- SE.getWord8 +             case tag of +               0 -> ItemStroke <$> SE.get+               1 -> ItemImage <$> SE.get+               _ -> fail "err in Item parsing"++-- |    +instance (SE.Serialize a, SE.Serialize b) => SE.Serialize (Pair a b) where+    put (x :!: y) = SE.put x+                    >> SE.put y+    get = (:!:) <$> SE.get <*> SE.get++    +-- | +data Dimension = Dim { dim_width :: !Double, dim_height :: !Double }+               deriving (Show,Eq,Ord)++-- | +instance SE.Serialize Dimension where +  put (Dim w h) = SE.put w >> SE.put h +  get = Dim <$> SE.get <*> SE.get++-- | +data Background = Background { bkg_type :: !S.ByteString +                             , bkg_color :: !S.ByteString +                             , bkg_style :: !S.ByteString +                             }+                | BackgroundPdf { bkg_type :: S.ByteString +                                , bkg_domain :: Maybe S.ByteString+                                , bkg_filename :: Maybe S.ByteString+                                , bkg_pageno :: Int+                                }+                deriving Show ++-- | +data Hoodle = Hoodle { hoodle_title :: !Title+                     , hoodle_pages :: ![Page] }+             deriving Show ++-- | +data Page = Page { page_dim :: !Dimension+                 , page_bkg :: !Background +                 , page_layers :: ![Layer] }+          deriving Show ++-- | +data Layer = Layer { layer_items :: ![Item] } +             -- Layer { layer_strokes :: ![Stroke] }+           deriving Show ++-- | +getXYtuples :: Stroke -> [(Double,Double)]+getXYtuples (Stroke _t _c _w d) = map (\(x :!: y) -> (x,y)) d+getXYtuples (VWStroke _t _c d) = map ((,)<$>fst3<*>snd3) d +++----------------------------+-- Lenses+----------------------------++-- | +tool :: Simple Lens Stroke ByteString+tool = lens stroke_tool (\f a -> f { stroke_tool = a })  ++-- | +color :: Simple Lens Stroke ByteString +color = lens stroke_color (\f a -> f { stroke_color = a } )++-- | +title :: Simple Lens Hoodle Title+title = lens hoodle_title (\f a -> f { hoodle_title = a } )++-- | +pages :: Simple Lens Hoodle [Page]+pages = lens hoodle_pages (\f a -> f { hoodle_pages = a } )++-- | +dimension :: Simple Lens Page Dimension +dimension = lens page_dim (\f a -> f { page_dim = a } )++-- | +background :: Simple Lens Page Background +background = lens page_bkg (\f a -> f { page_bkg = a } )++-- | +layers :: Simple Lens Page [Layer] +layers = lens page_layers (\f a -> f { page_layers = a } )++-- | +items :: Simple Lens Layer [Item]+items = lens layer_items (\f a -> f { layer_items = a } )++{-+-- | +strokes :: Simple Lens Layer [Stroke]+strokes = lens layer_strokes (\f a -> f { layer_strokes = a } )+-}++--------------------------+-- empty objects+--------------------------++-- | +emptyHoodle :: Hoodle+emptyHoodle = Hoodle "" [] ++-- | +emptyLayer :: Layer +emptyLayer = Layer { layer_items = [] } --  { layer_strokes = [] }++-- | +emptyStroke :: Stroke +emptyStroke = Stroke "pen" "black" 1.4 []++-- | +defaultBackground :: Background+defaultBackground = Background { bkg_type = "solid"+                               , bkg_color = "white"+                               , bkg_style = "lined" +                               }++-- | +defaultPage :: Page+defaultPage = Page { page_dim = Dim  612.0 792.0 +                   , page_bkg = defaultBackground+                   , page_layers = [ emptyLayer ] +                   } ++-- | +defaultHoodle :: Hoodle +defaultHoodle = Hoodle "untitled" [ defaultPage  ] ++-- | +newPageFromOld :: Page -> Page+newPageFromOld page = +  Page { page_dim = page_dim page +       , page_bkg = page_bkg page +       , page_layers = [emptyLayer] } +                   +
+ src/Data/Hoodle/Util.hs view
@@ -0,0 +1,29 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.Util+-- Copyright   : (c) 2011, 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Data.Hoodle.Util where++-- |++fst3 :: (a,b,c) -> a+fst3 (x,_,_) = x ++-- |++snd3 :: (a,b,c) -> b+snd3 (_,y,_) = y ++-- |++trd3 :: (a,b,c) -> c+trd3 (_,_,z) = z+
+ src/Data/Hoodle/Zipper.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE TypeSynonymInstances, TypeOperators, FlexibleInstances, +             StandaloneDeriving, DeriveFunctor, DeriveFoldable, +             DeriveTraversable  #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.Zipper +-- Copyright   : (c) 2011, 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- representing selection of hoodle type +-- +-----------------------------------------------------------------------------++module Data.Hoodle.Zipper where++import Control.Applicative hiding (empty)+import Control.Compose+import Data.Foldable+import Data.Monoid+import Data.Sequence hiding (fromList)+import Data.Traversable+-- from this package+import Data.Hoodle.Generic+-- import Data.Hoodle.Select++-- +import Prelude hiding (zipWith, length, splitAt)++-- |+newtype SeqZipper a = SZ { unSZ :: (a, (Seq a,Seq a)) } ++-- |+deriving instance Functor SeqZipper++-- |+deriving instance Foldable SeqZipper ++-- |+instance Applicative SeqZipper where+  pure = singletonSZ +  SZ (f,(f1s,f2s)) <*> SZ (x,(y1s,y2s)) = SZ (f x, (zipWith id f1s y1s, zipWith id f2s y2s))++-- |+deriving instance Traversable SeqZipper ++-- |+singletonSZ :: a -> SeqZipper a  +singletonSZ x = SZ (x, (empty,empty))++-- |+lengthSZ :: SeqZipper a -> Int +lengthSZ (SZ (_x, (x1s,x2s))) = length x1s + length x2s + 1 ++-- |+currIndex :: SeqZipper a -> Int+currIndex (SZ (_x, (x1s,_x2s))) = length x1s ++-- |+appendGoLast :: SeqZipper a -> a -> SeqZipper a+appendGoLast (SZ (y,(y1s,y2s))) x = SZ (x, ((y1s |> y) >< y2s, empty))++-- |+chopFirst :: SeqZipper a -> Maybe (SeqZipper a)+chopFirst (SZ (y,(y1s,y2s))) = +  case viewl y1s of+    EmptyL -> case viewl y2s of +                EmptyL -> Nothing +                z :< zs -> Just (SZ (z,(empty,zs)))+    _z :< zs -> Just (SZ (y,(zs,y2s)))+    +-- | +moveLeft :: SeqZipper a -> Maybe (SeqZipper a)+moveLeft (SZ (x,(x1s,x2s))) = +  case viewr x1s of+    EmptyR -> Nothing +    zs :> z -> Just (SZ (z,(zs,x<|x2s)))++-- |+moveRight :: SeqZipper a -> Maybe (SeqZipper a) +moveRight (SZ (x,(x1s,x2s))) = +  case viewl x2s of +    EmptyL -> Nothing+    z :< zs -> Just (SZ (z,(x1s|>x,zs)))++-- |+moveTo :: Int -> SeqZipper a -> Maybe (SeqZipper a) +moveTo n orig@(SZ (x,(x1s,x2s))) = +  let n_x1s = length x1s +      n_x2s = length x2s +      res | n < 0 || n > n_x1s + n_x2s = Nothing +          | n == n_x1s = Just orig +          | n < n_x1s = let (x1s1, x1s2) = splitAt n x1s +                            el :< rm = viewl x1s2+                        in Just (SZ (el, (x1s1,(rm |> x) >< x2s)))+          | n > n_x1s = let (x2s1,x2s2) = splitAt (n-n_x1s-1) x2s+                            el :< rm = viewl x2s2+                        in Just (SZ (el, ((x1s |> x) >< x2s1, rm)))+          | otherwise = error "error in moveTo"+  in res ++-- | +goFirst :: SeqZipper a -> SeqZipper a +goFirst orig@(SZ (x,(x1s,x2s))) =+  case viewl x1s of +    EmptyL -> orig+    z :< zs -> SZ (z,(empty, zs `mappend` (x <| x2s)))  ++-- |+goLast :: SeqZipper a -> SeqZipper a +goLast orig@(SZ (x,(x1s,x2s))) = +  case viewr x2s of +    EmptyR -> orig+    zs :> z -> SZ (z,((x1s |> x) `mappend` zs , empty))+ +-- | +current :: SeqZipper a -> a +current (SZ (x,(_,_))) = x++-- | +prev :: SeqZipper a -> Maybe a +prev = fmap current . moveLeft++-- |+next :: SeqZipper a -> Maybe a +next = fmap current . moveRight++-- |+replace :: a -> SeqZipper a -> SeqZipper a +replace y (SZ (_x,zs)) = SZ (y,zs)++-- |+deleteCurrent :: SeqZipper a -> Maybe (SeqZipper a)+deleteCurrent (SZ (_,(xs,ys))) = +  case viewl ys of +    EmptyL -> case viewr xs of +                EmptyR -> Nothing +                zs :> z -> Just (SZ (z,(zs,ys)))+    z :< zs -> Just (SZ (z,(xs,zs)))++-- |+data ZipperSelect a = NoSelect { allelems :: [a] }  +                    | Select { zipper :: (Maybe :. SeqZipper) a }++-- | +deriving instance Functor ZipperSelect ++-- |+selectFirst :: ZipperSelect a -> ZipperSelect a +selectFirst (NoSelect []) = NoSelect []+selectFirst (NoSelect lst@(_:_))  = Select . fromList $ lst+selectFirst (Select (O Nothing)) = NoSelect []+selectFirst (Select (O msz)) = Select . O $ return . goFirst =<<  msz++{-+instance Foldable (Maybe :. SeqZipper) where +  foldMap f (O Nothing) = mempty +  foldMap f (O (Just (SZ (x,(xs,ys))))) = foldMap f xs `mappend` f x `mappend` foldMap f ys +-}++-- |+instance Listable (Maybe :. SeqZipper) where+  fromList [] = O Nothing +  fromList (x:xs) = O (Just (SZ (x, (empty,fromList xs))))+--   toList (O Nothing) = [] +--   toList (O (Just (SZ (x,(xs,ys))))) = toList xs ++ (x : toList ys)++-- | +deriving instance Foldable ZipperSelect++-- |+deriving instance Traversable ZipperSelect+++-- |+instance Listable ZipperSelect where+  fromList xs = NoSelect xs+--   toList (NoSelect xs) = xs +--   toList (Select xs) = toList xs++++