diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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 +> -- } diff --git a/hoodle-types.cabal b/hoodle-types.cabal new file mode 100644 --- /dev/null +++ b/hoodle-types.cabal @@ -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 +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: + + + diff --git a/src/Data/Hoodle/BBox.hs b/src/Data/Hoodle/BBox.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hoodle/BBox.hs @@ -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 +-- 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) diff --git a/src/Data/Hoodle/Generic.hs b/src/Data/Hoodle/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hoodle/Generic.hs @@ -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 +-- 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 +-} diff --git a/src/Data/Hoodle/Generic/Simple.hs b/src/Data/Hoodle/Generic/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hoodle/Generic/Simple.hs @@ -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 +-- 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) + diff --git a/src/Data/Hoodle/Predefined.hs b/src/Data/Hoodle/Predefined.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hoodle/Predefined.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Hoodle.Predefined +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 diff --git a/src/Data/Hoodle/Select.hs b/src/Data/Hoodle/Select.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hoodle/Select.hs @@ -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 +-- 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}) + + diff --git a/src/Data/Hoodle/Simple.hs b/src/Data/Hoodle/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hoodle/Simple.hs @@ -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 +-- 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] } + + diff --git a/src/Data/Hoodle/Util.hs b/src/Data/Hoodle/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hoodle/Util.hs @@ -0,0 +1,29 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Hoodle.Util +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + diff --git a/src/Data/Hoodle/Zipper.hs b/src/Data/Hoodle/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hoodle/Zipper.hs @@ -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 +-- 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 + + + +