lp-diagrams 1.0 → 2.0

raw patch · 12 files changed

+745/−462 lines, 12 filesdep +addep +gaspdep +nonlinear-optimizationdep −glpk-hsPVP ok

version bump matches the API change (PVP)

Dependencies added: ad, gasp, nonlinear-optimization, reflection

Dependencies removed: glpk-hs

API changes (from Hackage documentation)

Files

• Algebra/AD.hs +112/−0
• Algebra/Linear.hs +31/−0
• Algebra/Linear/GaussianElimination.hs +32/−0
• Graphics/Diagrams/Core.hs +174/−245
• Graphics/Diagrams/DerivationTrees.hs +27/−27
• Graphics/Diagrams/Graphviz.hs +8/−7
• Graphics/Diagrams/Object.hs +120/−126
• Graphics/Diagrams/Path.hs +29/−27
• Graphics/Diagrams/Plot.hs +8/−6
• Graphics/Diagrams/Point.hs +23/−22
• Graphics/Diagrams/Types.hs +171/−0
• lp-diagrams.cabal +10/−2

@@ -0,0 +1,112 @@+{-# LANGUAGE RankNTypes, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RebindableSyntax #-}+module Algebra.AD (D(..),E(..),subst,dVar,var,sqrtE) where++import Algebra.Classes hiding ((:+))+import Data.Map (Map)+import qualified Data.Map.Strict as M+import Prelude hiding (Num(..),(/),fromRational,recip)+-- import Data.Vector as V+import Data.Function (on)++data AST v c = V v+  | AST v c :* AST v c+  | AST v c :+ AST v c+  | AST v c :- AST v c+  | K c++instance (Show v, Show c) => Show (AST v c) where+  showsPrec p (V v) = shows v+  showsPrec p (K c ) = shows c+  showsPrec p (x :+ y) = parens (p>2) (showsPrec 2 x . showString " + " . showsPrec 2 y)+  showsPrec p (x :* y) = parens (p>3) (showsPrec 3 x . showString " + " . showsPrec 3 y)++parens True x = showString "(" . x . showString ")"+parens False x = x++data D v c = D {dValue :: !c+               ,dDerivs :: !(Map v c)+               }+  deriving Show++dVar :: forall v c. Ring c => v -> c -> D v c+dVar v c = D c (M.singleton v 1)++var :: (Multiplicative c, Additive c, Ord v) => v -> E v c+var v = E $ \env -> env v++instance (Ord v,Additive c) => Additive (D v c) where+  zero = D zero zero+  D v1 d1 + D v2 d2 = D (v1 + v2) (d1 + d2)++instance (Ord v,Group c) => Group (D v c) where+  negate (D x d) = D (negate x) (negate d)+  D v1 d1 - D v2 d2 = D (v1 - v2) (d1 - d2)++instance Ord c => Ord (D v c) where+  compare = compare `on` dValue++instance Eq c => Eq (D v c) where+  (==) = (==) `on` dValue++instance (Ord v,Ring c) => Multiplicative (D v c) where+  one = D one zero+  D v1 d1 * D v2 d2 = D (v1 * v2) (v2 *^ d1 + v1 *^ d2)++instance (AbelianAdditive c,Ord v) => AbelianAdditive (D v c)+instance (Ord v,Ring c) => Module c (D v c) where+  k *^ D v d = D (k * v) (k *^ d)++instance (Ord v,Ring c) => Module (D v c) (D v c) where+  (*^) = (*)++instance (Ord v, Ring c) => Ring (D v c) where+  fromInteger k = D (fromInteger k) zero++newtype E v c = E {fromE :: (v -> D v c) -> D v c}++instance (Ord v,Additive c) => Additive (E v c) where+  zero = E (const zero)+  (+) = liftE2 (+)++instance (Ord v,Group c) => Group (E v c) where+  negate (E x) = E (negate . x)+  (-) = liftE2 (-)++instance (Ord v,Ring c) => Multiplicative (E v c) where+  one = E (const one)+  (*) = liftE2 (*)++instance (Ord v,Ring c) => AbelianAdditive (E v c)+instance (Ord v,Ring c) => Module c (E v c) where+  k *^ E x = E ((k *^) . x)++instance (Ord v,Ring c) => Module (E v c) (E v c) where+  (*^) = (*)++instance (Ord v, Ring c) => Ring (E v c) where+  fromInteger k = E (\ _ -> fromInteger k)++liftE2 :: forall t t1. (D t t1 -> D t t1 -> D t t1) -> E t t1 -> E t t1 -> E t t1+liftE2 f (E x) (E y) = E (\e -> f (x e) (y e))++liftE :: forall t t1. (D t t1 -> D t t1) -> E t t1 -> E t t1+liftE f (E x) = E (\e -> f (x e))++subst :: E v c -> (v -> E v c) -> E v c+subst (E p) f = E $ \k -> p (\a -> fromE (f a) k)++sqrtD :: (Ord v, Floating c, Field c) => D v c -> D v c+sqrtD (D v d) = D (sqrtv) ((0.5/sqrtv) *^ d)+  where sqrtv = sqrt v++sqrtE :: forall t t1. (Floating t1, Ord t, Field t1) => E t t1 -> E t t1+sqrtE = liftE sqrtD++instance (Field c,Ord v) => Division (D v c) where+  recip (D v d) = D (recip v) (negate (square iv) *^ d)+    where square x = x*x+          iv = recip v++instance (Field c,Ord v) => Division (E v c) where+  recip = liftE recip+  (/) = liftE2 (/)

@@ -0,0 +1,31 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, RebindableSyntax, DeriveFunctor #-}++module Algebra.Linear where++import Algebra.Classes+import Data.Map (Map)+import qualified Data.Map.Strict as M+import Prelude hiding (Num(..),(/))++data LinFunc v c = Func (Map v c) c+  deriving (Functor,Show)+type Constraint v c = LinFunc v c+++instance (Additive c,Ord v) => Additive (LinFunc v c) where+  zero = Func zero zero+  Func f1 k1 + Func f2 k2 = Func (f1 + f2) (k1 + k2)++instance (Ord v, Group c) => Group (LinFunc v c) where+  negate = fmap negate++instance (Ord v,AbelianAdditive c) => AbelianAdditive (LinFunc v c) where++instance (Ord v,Ring c) => Module c (LinFunc v c) where+  s *^ Func f k = Func (s *^ f) (s * k)++clean :: (Eq v, Eq c, Ring c) => LinFunc v c -> LinFunc v c+clean (Func f k) = Func (M.fromAscList $ filter ((/=0) . snd) $ M.assocs f) k++var :: Ring c => v -> LinFunc v c+var v = Func (M.singleton v 1) 0

@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, RebindableSyntax, DeriveFunctor #-}+module Algebra.Linear.GaussianElimination (linSolve) where++import Prelude hiding (Num(..),(/))+import Algebra.Classes+import qualified Data.Map.Strict as M+import Data.Maybe+import Algebra.Linear++gaussianElim :: (Ord v,Eq c,Field c) => [Constraint v c] -> [(v,LinFunc v c)]+gaussianElim [] = []+gaussianElim (co@(Func f k):cos) = case M.minViewWithKey f of+  Nothing -> if k == 0 then gaussianElim cos+             else error "gaussianElim: unsatisfiable"+  Just ((_,0),_) -> error "gaussianElim: invariant not respected"+  Just ((v,c),_) -> (v,clean $ var v - co') : gaussianElim (fmap t cos)+    where co' = (1/c) *^ co+          t co2@(Func m _) = case (M.lookup v m) of+            Nothing -> co2+            Just cv -> clean (co2 - cv *^ co')++substitution :: (Ord v,Ring c, Eq c) => [(v,LinFunc v c)] -> [(v,LinFunc v c)]+substitution [] = []+substitution ((v,f):vfs) = (v,f) : substitution [(v',subst v f f') | (v',f') <- vfs]++subst :: (Eq scalar, Ord v, Ring scalar) => v -> LinFunc v scalar -> LinFunc v scalar -> LinFunc v scalar+subst v f f'@(Func m _) = clean $ f' - coef *^ var v + coef *^ f+  where coef = fromMaybe 0 (M.lookup v m)+++linSolve :: (Eq c, Ord v, Field c) => [Constraint v c] -> [(v, LinFunc v c)]+linSolve = substitution . reverse . gaussianElim . fmap clean

@@ -1,329 +1,234 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell, RankNTypes, GADTs, ImpredicativeTypes #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell, RankNTypes, GADTs, ImpredicativeTypes, DeriveFunctor, ScopedTypeVariables, ConstraintKinds #-} -module Graphics.Diagrams.Core (module Graphics.Diagrams.Core) where-import Control.Monad.LPMonad-import Prelude hiding (sum,mapM_,mapM,concatMap)+module Graphics.Diagrams.Core (+  module Graphics.Diagrams.Types,+  Expr, constant, newVars,+  minimize, maximize,+  (===), (>==), (<==), (=~=),+  GExpr,+  minimize', maximize',+  fromLinear,+  Diagram(..), runDiagram,+  drawText,+  freeze, relax, tighten,+  registerNonOverlap+  ) where++import Prelude hiding (sum,mapM_,mapM,concatMap,Num(..),(/),fromRational,recip,(/)) import Control.Monad.RWS hiding (forM,forM_,mapM_,mapM)-import Data.LinearProgram-import Data.LinearProgram.Common as Graphics.Diagrams.Core (VarKind(..))-import Data.LinearProgram.LinExpr+import Algebra.Classes as AC+import Algebra.Linear as Linear+import Algebra.Linear.GaussianElimination import Data.Map (Map)-import qualified Data.Map as M+import qualified Data.Map.Strict as M import Control.Lens hiding (element) import Data.Traversable import Data.Foldable--- import MarXup.MultiRef (BoxSpec)--- import MarXup.Tex import System.IO.Unsafe--type LPState = LP Var Constant---- | Solution of the linear programming problem-type Solution = Map Var Double+import Data.Vector (Vector,(!))+import qualified Data.Vector as V+import qualified Data.Vector.Storable as S+import Numeric.Optimization.Algorithms.HagerZhang05 hiding (optimize)+import qualified Numeric.Optimization.Algorithms.HagerZhang05 as HagerZhang05+import Algebra.AD as AD+import Graphics.Diagrams.Types  -type Constant = Double- -- | Expressions are linear functions of the variables-type Expr = LinExpr Var Constant--data Point' a = Point {xpart :: a, ypart :: a}-  deriving (Eq,Show)--instance Traversable Point' where-  traverse f (Point x y) = Point <$> f x <*> f y--instance Foldable Point' where-  foldMap = foldMapDefault--instance Functor Point' where-  fmap = fmapDefault--instance Applicative Point' where-  pure x = Point x x-  Point f g <*> Point x y = Point (f x) (g y)--instance Group a => Num (Point' a) where-  negate = neg-  (+) = (^+^)-  (-) = (^-^)--instance Group v => Group (Point' v) where-  zero = Point zero zero-  Point x1 y1 ^+^ Point x2 y2 = Point (x1 ^+^ x2) (y1 ^+^ y2)-  neg (Point x y) = Point (neg x) (neg y)--instance Module Constant v => Module Constant (Point' v) where-  k *^ Point x y = Point (k *^ x) (k *^ y)--type Frozen x = x Constant-type FrozenPoint = Frozen Point'-type FrozenPath = Frozen Path'---data Segment v = CurveTo (Point' v) (Point' v) (Point' v)-                   | StraightTo (Point' v)-                   | Cycle-                     -- Other things also supported by tikz:-                   --  Rounded (Maybe Constant)-                   --  HV point | VH point-  deriving (Show,Eq)-instance Functor Segment where-  fmap = fmapDefault--instance Foldable Segment where-  foldMap = foldMapDefault-instance Traversable Segment where-  traverse _ Cycle = pure Cycle-  traverse f (StraightTo p) = StraightTo <$> traverse f p-  traverse f (CurveTo c d q) = CurveTo <$> traverse f c <*> traverse f d <*> traverse f q---data Path' a-  = EmptyPath-  | Path {startingPoint :: Point' a-         ,segments :: [Segment a]}-  deriving Show--- mapPoints :: (Point' a -> Point' b) -> Path' a -> Path' b-instance Functor Path' where-  fmap = fmapDefault--instance Foldable Path' where-  foldMap = foldMapDefault-instance Traversable Path' where-  traverse _ EmptyPath = pure EmptyPath-  traverse f (Path s ss) = Path <$> traverse f s <*> traverse (traverse f) ss----- | Tikz decoration-newtype Decoration = Decoration String----- | Tikz line tip-data LineTip = ToTip | CircleTip | NoTip | StealthTip | LatexTip | ReversedTip LineTip | BracketTip | ParensTip---- | Tikz color-type Color = String---- | Tikz line cap-data LineCap = ButtCap | RectCap | RoundCap---- | Tikz line join-data LineJoin = MiterJoin | RoundJoin | BevelJoin---- | Tikz dash pattern-type DashPattern = [(Constant,Constant)]---- | Path drawing options-data PathOptions = PathOptions-                     {_drawColor :: Maybe Color-                     ,_fillColor :: Maybe Color-                     ,_lineWidth :: Constant-                     ,_startTip  :: LineTip-                     ,_endTip    :: LineTip-                     ,_lineCap   :: LineCap-                     ,_lineJoin  :: LineJoin-                     ,_dashPattern :: DashPattern-                     ,_decoration :: Decoration-                     }-$(makeLenses ''PathOptions)---- | Size of a box, in points. boxDepth is how far the baseline is--- from the bottom. boxHeight is how far the baseline is from the top.--- (These are TeX meanings)-data BoxSpec = BoxSpec {boxWidth, boxHeight, boxDepth :: Double}-             deriving (Show)--nilBoxSpec :: BoxSpec-nilBoxSpec = BoxSpec 0 0 0--data Backend lab m =-                 Backend {_tracePath :: PathOptions -> FrozenPath -> m ()-                         ,_traceLabel :: forall location (x :: * -> *). Monad x =>-                                                 (location -> (FrozenPoint -> m ()) -> x ()) -> -- freezer-                                                 (forall a. m a -> x a) -> -- embedder-                                                 location ->-                                                 lab -> -- label specification-                                                 x BoxSpec-                         }-+type Expr = LinFunc Var Constant --- tracePath :: Lens' (Backend m) (PathOptions -> FrozenPath -> m ())--- tracePath f (Backend {..}) = fmap (\a -> Backend {_tracePath = a,..}) (f _tracePath)+newtype Var = Var Int+  deriving (Ord,Eq,Show,Enum) --- renderLabel :: Lens' (Backend m) (FrozenPoint -> m () -> m ())--- renderLabel f (Backend {..}) = fmap (\a -> Backend {_renderLabel = a,..}) (f _renderLabel)+-- | A non-linear expression.+type GExpr = E Var Constant --- declareLabel :: Lens' (Backend m) (FrozenPoint -> m () -> m ())--- declareLabel f (Backend {..}) = fmap (\a -> Backend {_declareLabel = a,..}) (f _declareLabel)+fromLinear :: Expr -> GExpr+fromLinear m = fromLinear' one m AD.var -$(makeLenses ''Backend) -- does not work due to the existential+fromLinear' :: forall a scalar. (Module scalar a) => a -> LinFunc Var scalar -> (Var -> a) -> a+fromLinear' unit (Func m c) f = c *^ unit + fromSum (M.foldMapWithKey (\v k -> AC.Sum (k *^ f v)) m) -data Env lab m = Env {_diaTightness :: Constant -- ^ Multiplicator to minimize constraints-                     ,_diaPathOptions :: PathOptions-                     ,_diaBackend :: Backend lab m}+substLinear :: Expr -> (Var -> Expr) -> Expr+substLinear = fromLinear' (Func M.empty 1) -$(makeLenses ''Env)+rename :: (Var -> Var) -> Expr -> Expr+rename f e = substLinear e (Linear.var . f)  +-- | Some action to perform after a solution has been found.+data Freeze m where+  Freeze :: forall t m. Functor t => (t Constant -> m ()) -> t Expr -> Freeze m -defaultPathOptions :: PathOptions-defaultPathOptions = PathOptions-  {_drawColor = Nothing-  ,_fillColor = Nothing-  ,_lineWidth = 0.4-  ,_startTip  = NoTip-  ,_endTip    = NoTip-  ,_lineCap   = ButtCap-  ,_lineJoin  = MiterJoin-  ,_dashPattern = []-  ,_decoration = Decoration ""+data DiagramState = DiagramState+  {_diaNextVar :: Var+  ,_diaLinConstraints :: [Constraint Var Constant]+  ,_diaObjective :: GExpr+  ,_diaVarNames :: Map Var String+  ,_diaNoOverlaps :: [Pair (Point' GExpr)]   } -data Freeze m where-  Freeze :: forall t m. Functor t => (t Constant -> m ()) -> t Expr -> Freeze m+$(makeLenses ''DiagramState) -newtype Diagram lab m a = Dia (RWST (Env lab m) [Freeze m] (Var,LPState) m a)-  deriving (Monad, Applicative, Functor, MonadReader (Env lab m), MonadWriter [Freeze m])+newtype Diagram lab m a = Dia {fromDia :: (RWST (Env lab m) [Freeze m] DiagramState m a)}+  deriving (Monad, Applicative, Functor, MonadReader (Env lab m), MonadWriter [Freeze m], MonadState DiagramState) +-- | @freeze x f@ performs @f@ on the frozen value of @x@. freeze :: (Functor t, Monad m) => t Expr -> (t Constant -> m ()) -> Diagram lab m () freeze x f = tell [Freeze (\y -> (f y)) x] -instance Monad m => MonadState LPState (Diagram lab m) where-  get = Dia $ snd <$> get-  put y = Dia $ do-    (x,_) <- get-    put (x,y)  ------------- -- Diagrams  -relax :: Monad m => Constant -> Diagram lab m a -> Diagram lab m a-relax factor = tighten (1/factor)+-- | Relax the optimisation functions by the given factor+relax :: Monad m => Rational -> Diagram lab m a -> Diagram lab m a+relax factor = tighten (one/factor) -tighten :: Monad m => Constant -> Diagram lab m a -> Diagram lab m a+-- | Tighten the optimisation functions by the given factor+tighten :: Monad m => Rational -> Diagram lab m a -> Diagram lab m a tighten factor = local (over diaTightness (* factor)) --- instance Monoid (Diagram lab m ()) where---   mempty = return ()---   mappend = (>>)---- instance IsString (Diagram ()) where---   fromString = diaRawTex . tex- -------------- -- Variables -rawNewVar :: Monad m => Diagram lab m Var-rawNewVar = Dia $ do-      (Var x,y) <- get-      put $ (Var (x+1),y)-      return $ Var x -newVar :: Monad m => Diagram lab m Expr-newVar = do-  [v] <- newVars [ContVar]+newVar :: Monad m => String -> Diagram lab m Expr+newVar name = do+  [v] <- newVars [name]   return v -newVars :: Monad m => [VarKind] -> Diagram lab m [Expr]-newVars kinds = newVars' (zip kinds (repeat Free))--newVars' :: Monad m => [(VarKind,Bounds Constant)] -> Diagram lab m [Expr]-newVars' kinds = forM kinds $ \(k,b) -> do-  v <- rawNewVar-  setVarKind v k-  setVarBounds v b+newVars :: Monad m => [String] -> Diagram lab m [Expr]+newVars kinds = forM kinds $ \name -> do+  v <- rawNewVar name   return $ variable v+ where rawNewVar :: Monad m => String -> Diagram lab m Var+       rawNewVar name = Dia $ do+         Var x <- use diaNextVar+         diaNextVar .= Var (x+1)+         diaVarNames %= M.insert (Var x) name+         return $ Var x + infix 4 <==,===,>==  ---------------- -- Expressions-instance Fractional Expr where-  fromRational ratio = constant (fromRational ratio) -instance Num Expr where-  fromInteger x = LinExpr M.empty (fromInteger x)-  negate = neg-  (+) = (^+^)-  (-) = (^-^)  runDiagram :: Monad m => Backend lab m -> Diagram lab m a -> m a-runDiagram backend (Dia diag) = do-  (a,(_,problem),ds) <- runRWST diag (Env 1 defaultPathOptions backend)-                                        (Var 0,LP Min M.empty [] M.empty M.empty)-  let solution = case unsafePerformIO $ glpSolveVars simplexDefaults problem of-        (_retcode,Just (_objFunc,s)) -> s-        (retcode,Nothing) -> error $ "LP failed ret code = " ++ show retcode-  -- Raw Normal $ "%problem solved: " ++ show problem ++ "\n"-  forM_ ds (\(Freeze f x) -> f (fmap (valueIn solution) x))+runDiagram backend diag = do+  let env = Env one defaultPathOptions backend+  (a,finalState,ds) <- runRWST (fromDia $ do x<-diag;resolveNonOverlaps;return x) env $+    DiagramState (Var 0) [] zero (M.empty) []+  let reducedConstraints = M.fromList $ linSolve (finalState ^. diaLinConstraints)+      linSolvSubst v = case M.lookup v reducedConstraints of+        Nothing -> Linear.var v+        Just x -> x+      solvSubst = fromLinear . linSolvSubst+      maxVar =  finalState ^. diaNextVar+      freeVars = filter (\v -> M.notMember v reducedConstraints) [Var 0..maxVar]+      varsToFreeVars' :: Map Var Int+      varsToFreeVars' = M.fromList (zip freeVars [0..])+      freeVarsToVars :: V.Vector Var+      freeVarsToVars = V.fromList freeVars++      obj' :: GExpr+      obj' = AD.subst (finalState ^. diaObjective) solvSubst+      grad' rho = (y,fmap (\v -> M.findWithDefault zero v dy) freeVarsToVars)+         where D y dy = fromE obj' (\v -> maybe (error "not found") id (M.lookup v env') )+               env' = M.mapWithKey (\v i -> D (rho ! i) (M.singleton v 1)) varsToFreeVars'+      (solution,_result,_statistics) = unsafePerformIO $ do+       putStrLn $ "free vars: " ++ show freeVars+       putStrLn $ "reducedConstraints: " ++ show reducedConstraints+       putStrLn $ "optimizing ..."+       opt@(s,_,_) <- HagerZhang05.optimize+        defaultParameters {verbose = VeryVerbose}+        0.01+        (V.replicate (length freeVars) 0)+        (VFunction (fst . grad')) (VGradient (snd . grad')) (Just (VCombined grad'))+       putStrLn $ "done: "  ++ show (grad' (S.convert s))+       return opt+      solution' = fmap (solution S.!) varsToFreeVars'+      fullSolution = M.union solution' (fmap (valueIn solution') reducedConstraints)++  forM_ ds (\(Freeze f x) -> f (fmap (valueIn fullSolution) x))   return a  -valueIn :: Solution -> Expr -> Double-valueIn sol (LinExpr m c) = sum (c:[scale * varValue v | (v,scale) <- M.assocs m])- where varValue v = M.findWithDefault 0 v sol+valueIn :: Map Var Double -> Expr -> Double+valueIn sol f = fromLinear' one f (\v -> M.findWithDefault 0 v sol) +-- | Embed a variable in an expression variable :: Var -> Expr-variable v = LinExpr (var v) 0+variable v = Func (M.singleton v 1) 0 +-- | Embed a constant in an expression constant :: Constant -> Expr-constant c = LinExpr M.empty c--(*-) :: Module Constant a => Constant -> a -> a-(*-) = (*^)-infixr 6 *---avg :: Module Constant a => [a] -> a-avg xs = (1/fromIntegral (length xs)) *- gsum xs---- | Absolute value, which can be MINIMIZED or put and upper bound on (but not--- the other way around).-absoluteValue :: Monad m => Expr -> Diagram lab m Expr-absoluteValue x = do-  [t1,t2] <- newVars' [(ContVar,LBound 0),(ContVar,LBound 0)]-  t1 - t2 === x-  return $ t1 + t2+constant c = Func M.empty c -satAll :: Monad m => (Expr -> a -> Diagram lab m b) -> [a] -> Diagram lab m Expr-satAll p xs = do-  [m] <- newVars [ContVar]+satAll :: Monad m => String -> (Expr -> a -> Diagram lab m b) -> [a] -> Diagram lab m Expr+satAll name p xs = do+  [m] <- newVars [(name)]   mapM_ (p m) xs   return m  -- | Minimum or maximum of a list of expressions. maximVar, minimVar :: Monad m => [Expr] -> Diagram lab m Expr-maximVar = satAll (>==)-minimVar = satAll (<==)+maximVar = satAll "maximum of" (>==)+minimVar = satAll "minimum of" (<==)  -------------- -- Expression constraints (===), (>==), (<==) :: Expr -> Expr -> Monad m => Diagram lab m () e1 <== e2 = do-  let LinExpr f c = e1 - e2-  leqTo f (negate c)+  let Func f c = e1 - e2+      isFalse = M.null f && c < 0+  when isFalse $ error "Diagrams.Core: inconsistent constraint!"+  minimize' $ E $ \s ->+    let [v1,v2] = map (($ s) . fromE . fromLinear) [e1,e2]+    in if v1 <= v2 then zero else square (square (v2-v1)) +prettyExpr :: Monad m => Expr -> Diagram lab m String+prettyExpr (Func f k) = do+  vnames <- Dia (use diaVarNames)+  let vname n = case M.lookup n vnames of+        Nothing -> error ("prettyExpr: variable not found: " ++ show n)+        Just nm -> nm+  return $ prettySum ([prettyProd c (vname v) | (v,c) <- M.assocs f]  ++ [show k | k /= 0])+  where prettySum [] = "0"+        prettySum xs = foldr1 prettyPlus xs+        prettyPlus a ('-':b) = a ++ ('-':b)+        prettyPlus x y = x ++ "+" ++ y+        prettyProd 1 v = show v+        prettyProd (-1) v = '-' : show v+        prettyProd c v = show c ++ show v+ (>==) = flip (<==)  e1 === e2 = do-  let LinExpr f c = e1 - e2-  equalTo f (negate c)+  constrName <- (\x y -> x ++ " = " ++ y) <$> prettyExpr e1 <*> prettyExpr e2+  diaLinConstraints %= (e1 - e2 :)  -- | minimize the distance between expressions-(=~=) :: Monad m => Expr -> Expr -> Diagram lab m ()-x =~= y = minimize =<< absoluteValue (x-y)+(=~=) :: Monad m => GExpr -> GExpr -> Diagram lab m ()+x =~= y = minimize' $ square (x-y)  ------------------------- -- Expression objectives  minimize,maximize :: Monad m => Expr -> Diagram lab m ()-minimize (LinExpr x _) = do-  tightness <- view diaTightness-  addObjective (tightness *- x)+minimize = minimize' . fromLinear maximize = minimize . negate +minimize',maximize' :: Monad m => GExpr -> Diagram lab m ()+maximize' = minimize' . negate+minimize' f = do+  tightness <- view diaTightness+  diaObjective %= \o -> (fromRational tightness::Double) *^ f + o + drawText :: Monad m => Point' Expr -> lab -> Diagram lab m BoxSpec drawText point lab = do   tl <- view (diaBackend . traceLabel)@@ -331,3 +236,27 @@  diaRaw :: Monad m => m a -> Diagram lab m a diaRaw = Dia . lift++--------------------------+-- Non-overlapping things++registerNonOverlap :: Monad m => Point' Expr -> Point' Expr -> Diagram lab m ()+registerNonOverlap nw se = Dia $ diaNoOverlaps %= (Pair (fromLinear <$> nw) (fromLinear <$>  se):)++surface :: forall a. Multiplicative a => Point' a -> a+surface (Point x y) = x*y++resolveNonOverlaps :: Monad m => Diagram lab m ()+resolveNonOverlaps = do+  noOvl <- Dia $ use diaNoOverlaps+  minimize' $ E $ \s ->+    add $ do+      pair <- allPairs noOvl+      let (Pair bx1 bx2) = fmap (fmap (fmap (($ s) . fromE))) pair+          overlap = inters bx1 bx2+      return $ if nonEmpty overlap then (square $ surface overlap) else zero+    where+      allPairs [] = []+      allPairs (x:xs) = [Pair x y | y <- xs] ++ allPairs xs+      inters (Pair p1 q1) (Pair p2 q2) = (min <$> q1 <*> q2) - (max <$> p1 <*> p2)+      nonEmpty (Point a b) = a > zero && b > zero

@@ -22,8 +22,10 @@ import Control.Monad.Writer import Data.LabeledTree import Data.Monoid-import Graphics.Diagrams as D+import Graphics.Diagrams as D hiding (label) import qualified Data.Tree as T+import Algebra.Classes+import Prelude hiding (Num(..)) ------------------ --- Basics @@ -69,36 +71,36 @@  derivationTreeDiag :: Monad m => Derivation lab -> Diagram lab m () derivationTreeDiag d = do-  [h] <- newVars [ContVar] -- the height of a layer in the tree.+  [h] <- newVars ["height"] -- the height of a layer in the tree.   minimize h-  h >== 1+  h >== constant 1   tree@(T.Node (_,n,_) _) <- toDiagram h d   forM_ (T.levels tree) $ \ls ->     case ls of       [] -> return ()       (_:ls') -> forM_ (zip ls ls') $ \((_,_,l),(r,_,_)) ->-        (l + Point 10 0) `westOf` r+        (l + Point (constant 10) zero) `westOf` r   let leftFringe = map head nonNilLevs       rightFringe = map last nonNilLevs       nonNilLevs = filter (not . null) $ T.levels tree-  [leftMost,rightMost] <- newVars [ContVar,ContVar]+  [leftMost,rightMost] <- newVars ["leftMost","rightMost"]   forM_ leftFringe $ \(p,_,_) ->     leftMost <== xpart p   forM_ rightFringe $ \(_,_,p) ->     xpart p <== rightMost   minimize $ 10 *- (rightMost - leftMost)-  n # Center .=. Point 0 0+  n # Center .=. zero -toDiagPart :: Monad m => Expr -> Premise lab -> Diagram lab m (T.Tree (Point,Anchorage,Point))+toDiagPart :: Monad m => Expr -> Premise lab -> Diagram lab m (T.Tree (Point,Object,Point)) toDiagPart layerHeight (Link{..} ::> rul)   | steps == 0 = toDiagram layerHeight rul   | otherwise = do     above@(T.Node (_,concl,_) _) <- toDiagram layerHeight rul-    ptObj <- vrule+    ptObj <- vrule "ptObj"     let pt = ptObj # S     pt `eastOf` (concl # W)     pt `westOf` (concl # E)-    xpart pt =~= xpart (concl # Center)+    fromLinear (xpart pt) =~= fromLinear (xpart (concl # Center))     let top = ypart (concl # S)     ypart pt + (fromIntegral steps *- layerHeight) === top     using linkStyle $ path $ polyline [ptObj # Base,Point (xpart pt) top]@@ -112,12 +114,12 @@ -- - Returns an object encompassing the group, with a the baseline set correctly. -- - Returns the average distance between the objects -chainBases :: Monad m => Expr -> [Anchorage] -> Diagram lab m (Anchorage,Expr)+chainBases :: Monad m => Expr -> [Object] -> Diagram lab m (Object,Expr) chainBases _ [] = do-  o <- box-  return (o,0)+  o <- box "empty"+  return (o,zero) chainBases spacing ls = do-  grp <- box+  grp <- box "grp"   forM_ [Base,N,S] $ \ anch -> do     D.align ypart $ map (# anch) (grp:ls)   dxs <- forM (zip ls (tail ls)) $ \(x,y) -> do@@ -130,9 +132,9 @@  -- | Put object in a box of the same vertical extent, and baseline, -- but whose height can be bigger.-relaxHeight :: (Monad m, Anchored a) => a -> Diagram lab m Anchorage+relaxHeight :: (Monad m) => Object -> Diagram lab m Object relaxHeight o = do-  b <- box+  b <- box "relaxed"   -- using (outline "green")$ traceBounds o   D.align xpart [b#W,o#W]   D.align xpart [b#E,o#E]@@ -140,20 +142,20 @@   o `fitsVerticallyIn` b   return b -toDiagram :: Monad m => Expr -> Derivation lab -> Diagram lab m (T.Tree (Point,Anchorage,Point))+toDiagram :: Monad m => Expr -> Derivation lab -> Diagram lab m (T.Tree (Point,Object,Point)) toDiagram layerHeight (Node Rule{..} premises) = do   ps <- mapM (toDiagPart layerHeight) premises-  concl <- relaxHeight =<< extend 1.5 <$> labelBox conclusion+  concl <- relaxHeight =<< extend (constant 1.5) <$> rawLabel "concl" conclusion   -- using (outline "red")$ traceBounds concl-  lab <- labelBox ruleLabel+  lab <- rawLabel "rulename" ruleLabel    -- Grouping-  (psGrp,premisesDist) <- chainBases 10 [p | T.Node (_,p,_) _ <- ps]+  (psGrp,premisesDist) <- chainBases (constant 10) [p | T.Node (_,p,_) _ <- ps]   -- using (outline "blue" . denselyDotted) $ traceBounds psGrp   height psGrp === layerHeight -  -- Sepaartion rule-  separ <- hrule+  -- Separation rule+  separ <- hrule "separation"   separ # N .=. psGrp # S   align ypart [concl # N,separ # S]   minimize $ width separ@@ -161,16 +163,15 @@   concl `fitsHorizontallyIn` separ    -- rule label-  lab # BaseW .=. separ # E + Point 3 (negate 1)+  lab # BaseW .=. separ # E + Point (constant 3) (constant (negate 1))     -- layout hints (not necessary for "correctness")   let xd = xdiff (separ # W) (psGrp # W)-  xd   === xdiff (psGrp # E) (separ # E) -  relax 2 $ (2 *- xd) =~= premisesDist+  xd   === xdiff (psGrp # E) (separ # E)+  relax 2 $ fromLinear (2 *- xd) =~= fromLinear premisesDist   -- centering of conclusion-  xd' <- absoluteValue $ xdiff (separ # Center) (concl # Center)-  relax 3 $ minimize xd'+  relax 3 $ minimize' $ sqNorm $ fmap fromLinear $ (separ # Center) - (concl # Center)    -- draw the rule.   using ruleStyle $ path $ polyline [separ # W,separ # E]@@ -196,4 +197,3 @@      [lnk {steps = 1, label = tex} ::> emptyDrv]   where lnk :: Link lab         lnk = defaultLink-

@@ -20,7 +20,7 @@ graph labFct cmd gr = graphToDiagram labFct $ layout cmd gr  layout :: (PrintDotRepr g n, ParseDot n, PrintDot n) => GraphvizCommand -> g n -> Gen.DotGraph n-layout command input = parseIt' $ unsafePerformIO $ graphvizWithHandle command input DotOutput hGetStrict +layout command input = parseIt' $ unsafePerformIO $ graphvizWithHandle command input DotOutput hGetStrict  pos (Pos p) = Just p pos _= Nothing@@ -49,9 +49,12 @@   _ -> k2  +pt' :: G.Point -> Point' Double pt' (G.Point x y _z _forced) = D.Point x y-pt = unfreeze . pt' +pt :: G.Point -> Point' Expr+pt = fmap constant . pt'+ diaSpline :: [FrozenPoint] -> [Graphics.Typography.Geometry.Bezier.Curve] diaSpline (w:x:y:z:rest) = curveSegment w x y z:diaSpline (z:rest) diaSpline _ = []@@ -71,7 +74,7 @@       -- diaRaw $ tex $ "%Edge: " ++ show attrs ++ "\n"       let toTip = readAttr' arrowHeadA attrs (tipTop ToTip) ToTip       readAttr labelA attrs $ \(StrLabel l) ->-        readAttr lpos attrs $ \p -> +        readAttr lpos attrs $ \p ->         renderLab l p       readAttr pos attrs $ \(SplinePos splines) ->         forM_ splines $ \Spline{..} -> do@@ -95,16 +98,14 @@          readAttr shapeA attrs $ \s ->           case s of             Circle -> do-              draw $ path $ circle (pt p) (constant $ inch (w/2))+              draw $ path $ circlePath (pt p) (constant $ inch (w/2))             _ -> return ()     _ -> return ()   where   renderLab :: T.Text -> G.Point -> Diagram l m ()   renderLab l p = do-    l' <- labelObj $ labFct $ T.unpack $ l+    l' <- rawLabel "graphVizLab" $ labFct $ T.unpack $ l     l' # D.Center .=. pt p   inch x = 72 * x--

@@ -1,17 +1,14 @@-{-# LANGUAGE DataKinds, KindSignatures, OverloadedStrings, EmptyDataDecls, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, GADTs, LambdaCase   #-}+{-# LANGUAGE DataKinds, KindSignatures, OverloadedStrings, EmptyDataDecls, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, GADTs, LambdaCase, RecordWildCards   #-}  module Graphics.Diagrams.Object where --- import MarXup--- import MarXup.Tex import Graphics.Diagrams.Path import Graphics.Diagrams.Point import Graphics.Diagrams.Core import Control.Monad--- import Control.Applicative--- import Data.Algebra--- import Data.List (intersperse) import Control.Lens (set,view)+import Algebra.Classes hiding (normalize)+import Prelude hiding (Num(..))  data Anchor = Center | N | NW | W | SW | S | SE | E | NE | BaseW | Base | BaseE   deriving Show@@ -19,180 +16,164 @@ -- | Box-shaped object. (a subtype) type Box = Object -newtype Anchorage = Anchorage {fromAnchorage :: Anchor -> Point}-data Object = Object {objectOutline :: Path, objectAnchorage :: Anchorage}+type Anchorage = Anchor -> Point+data Object = Object {objectName :: String, objectOutline :: Path, anchors :: Anchorage} -class Anchored a where-  anchors :: a -> Anchorage-  + infix 8 # -(#) :: Anchored a => a -> Anchor -> Point-(#) = fromAnchorage . anchors+(#) :: Object -> Anchor -> Point+(#) = anchors -instance Anchored Anchorage where-  anchors = id -instance Anchored Object where-  anchors = objectAnchorage--instance Anchored Point where-  anchors p = Anchorage $ \_ -> p- -- | Horizontal distance between objects-hdist :: Anchored a => a -> a -> Expr+hdist :: Object -> Object -> Expr hdist x y = xpart (y # W - x # E)  -- | Vertical distance between objects-vdist :: Anchored a => a -> a -> Expr+vdist :: Object -> Object -> Expr vdist x y = ypart (y # S - x # N) --- | Extend the box boundaries by the given delta-extend :: Expr -> Anchorage -> Anchorage-extend e o = Anchorage $ \a -> o # a + shiftInDir a e+-- | Move the anchors (NSEW) by the given delta, outwards.+extend :: Expr -> Object -> Object+extend e Object{..} = Object{anchors = \a -> anchors a + shiftInDir a e,..}  -- | Makes a shift of size 'd' in the given direction. shiftInDir :: Anchor -> Expr -> Point-shiftInDir N d = 0 `Point` d-shiftInDir S d = 0 `Point` negate d-shiftInDir W d = negate d `Point` 0-shiftInDir BaseW d = negate d `Point` 0-shiftInDir E d  = d `Point` 0-shiftInDir BaseE d  = d `Point` 0+shiftInDir N d = zero `Point` d+shiftInDir S d = zero `Point` negate d+shiftInDir W d = negate d `Point` zero+shiftInDir BaseW d = negate d `Point` zero+shiftInDir E d  = d `Point` zero+shiftInDir BaseE d  = d `Point` zero shiftInDir NW d = negate d `Point` d shiftInDir SE d = d `Point` negate d shiftInDir SW d = negate d `Point` negate d shiftInDir NE d = d `Point` d-shiftInDir _ _  = 0 `Point` 0+shiftInDir _ _  = zero `Point` zero --- | Make a label object. This is just some text surrounded by 4--- points of blank.-mkLabel :: Monad m => lab -> Diagram lab m Anchorage-mkLabel texCode = extend 4 <$> labelBox texCode+-- | Make a label object. This is the text surrounded by 4+-- points of blank and a rectangle outline. -labelObj :: Monad m => lab -> Diagram lab m Box-labelObj = rectangleShape <=< mkLabel+label :: Monad m => String -> lab -> Diagram lab m Box+label name txt = do+  l <- extend (constant 4) <$> rawLabel name txt+  pathObject $ Object+    name+    (polygon (map (l #) [NW,NE,SE,SW]))+    (anchors l) +-- | Internal use.+pathObject :: Monad m => Object -> Diagram lab m Object+pathObject o@(Object _ p _) = path p >> return o+ -- | Label a point by a given TeX expression, at the given anchor.-labelPt :: Monad m => lab -> Anchor -> Point -> Diagram lab m Box-labelPt labell anchor labeled  = do-  t <- labelObj labell+labelAt :: Monad m => String -> lab -> Anchor -> Point -> Diagram lab m Box+labelAt name labell anchor labeled  = do+  t <- label name labell   t # anchor .=. labeled   return t  -- | A free point-point :: Monad m => Diagram lab m Point-point = do-  [x,y] <- newVars (replicate 2 ContVar)-  return $ Point x y+point :: Monad m => String -> Diagram lab m Object+point name = do+  [x,y] <- newVars [(name++".x"),(name++".y")]+  return $ Object name EmptyPath (\_ -> Point x y) --- | A point anchorage (similar to a box of zero width and height)-pointBox :: Monad m => Diagram lab m Anchorage-pointBox = anchors <$> point+-- -- | A free point+-- point' :: Monad m => Diagram lab m Object+-- point' = point "point"  -- | A box. Anchors are aligned along a grid.-box :: Monad m => Diagram lab m Anchorage-box = do-  [n,s,e,w,base,midx,midy] <- newVars (replicate 7 ContVar)+box :: Monad m => String -> Diagram lab m Object+box objectName = do+  [n,s,e,w,base,midx,midy] <- newVars $+     (map (\suff -> objectName++"."++suff) ["north","south","east","west","base","midx","midy"])   n >== base   base >== s   w <== e-  +   midx === avg [w,e]   midy === avg [n,s]   let pt = flip Point-  return $ Anchorage $ \anch -> case anch of-    NW     -> pt n    w-    N      -> pt n    midx-    NE     -> pt n    e  -    E      -> pt midy e-    SE     -> pt s    e-    S      -> pt s    midx-    SW     -> pt s    w-    W      -> pt midy w-    Center -> pt midy midx-    Base   -> pt base midx-    BaseE  -> pt base e-    BaseW  -> pt base w+      anchors anch = case anch of+        NW     -> pt n    w+        N      -> pt n    midx+        NE     -> pt n    e+        E      -> pt midy e+        SE     -> pt s    e+        S      -> pt s    midx+        SW     -> pt s    w+        W      -> pt midy w+        Center -> pt midy midx+        Base   -> pt base midx+        BaseE  -> pt base e+        BaseW  -> pt base w+      objectOutline = polygon (map anchors [NW,NE,SE,SW])+  pathObject $ Object{..}  -- | A box of zero width-vrule :: Monad m => Diagram lab m Anchorage-vrule = do-  o <- box+vrule :: Monad m => String -> Diagram lab m Object+vrule name = do+  o <- box name   align xpart [o # W, o #Center, o#E]   return o  -- | A box of zero height-hrule :: Monad m => Diagram lab m Anchorage-hrule = do-  o <- box-  height o === 0+hrule :: Monad m => String -> Diagram lab m Object+hrule name = do+  o <- box name+  height o === zero   return o -height, width, ascent, descent :: Anchored a => a -> Expr+height, width, ascent, descent :: Object -> Expr height o = ypart (o # N - o # S) width o = xpart (o # E - o # W) ascent o = ypart (o # N - o # Base) descent o = ypart (o # Base - o # S)  -- | Make one object fit (snugly) in the other.-fitsIn, fitsHorizontallyIn, fitsVerticallyIn :: (Monad m, Anchored a, Anchored b) => a -> b -> Diagram lab m ()+fitsIn, fitsHorizontallyIn, fitsVerticallyIn+  :: (Monad m) => Object -> Object -> Diagram lab m () o `fitsVerticallyIn` o' = do   let dyN = ypart $ o' # N - o # N       dyS = ypart $ o # S - o' # S   minimize dyN-  dyN >== 0+  dyN >== zero   minimize dyS-  dyS >== 0+  dyS >== zero  o `fitsHorizontallyIn` o' = do   let dyW = xpart $ o # W - o' # W       dyE = xpart $ o' # E - o # E   minimize dyW-  dyW >== 0+  dyW >== zero   minimize dyE-  dyE >== 0+  dyE >== zero  a `fitsIn` b = do   a `fitsHorizontallyIn` b   a `fitsVerticallyIn` b  -- | A circle-circleShape :: Monad m => Diagram lab m Object-circleShape = do-  anch <- box-  width anch === height anch-  let radius = 0.5 *- width anch-  let p = circle (anch # Center) radius-  path p-  return $ Object p anch---   let k1 :: Constant---       k1 = sqrt 2 / 2---       k = k1 *^ r---       p = circle center r---   return $ Object p $ Anchorage $ \a -> center + case a of---     N -> Point 0 r---     S -> Point 0 (-r)---     E -> Point r 0---     W -> Point (-r) 0---     Center -> Point 0 0---     NE -> Point k k--rectangleShape :: Monad m => Anchorage -> Diagram lab m Object-rectangleShape l = do-  let p = polygon (map (l #) [NW,NE,SE,SW])-  path p-  return $ Object p l+circle :: Monad m => String -> Diagram lab m Object+circle name = do+  bx <- noDraw (box name)+  width bx === height bx+  let radius = 0.5 *- width bx+      p = circlePath (bx # Center) radius+  pathObject $ Object name p (anchors bx) -traceAnchorage :: (Anchored a, Monad m) => Color -> a -> Diagram lab m ()-traceAnchorage c l = do+traceBox :: (Monad m) => Color -> Object -> Diagram lab m ()+traceBox c l = do   stroke c $ path $ polygon (map (l #) [NW,NE,SE,SW])   -- TODO: draw the baseline, etc. --- | Typeset a piece of text and return its bounding box.-labelBox :: Monad m => lab -> Diagram lab m Anchorage-labelBox t = do-  l <- box+-- | Typeset a piece of text and return its bounding box as an object. Probably,+-- use 'label' instead.+rawLabel :: Monad m => String -> lab -> Diagram lab m Object+rawLabel name t = do+  l <- noDraw (box name)   -- traceAnchorage "red" l   BoxSpec wid h desc <- drawText (l # NW) t @@ -217,7 +198,7 @@ instance Functor (FList xs) where   fmap _ NIL = NIL   fmap f (x :%> xs) = fmap f x :%> fmap f xs-  + -- | Traces a straight edge between two objects. -- A vector originated at the midpoint and pointing perpendicular to -- the edge is returned.@@ -239,7 +220,7 @@   y1 <== y2  -- | Forces the point to be inside the (bounding box) of the object.-insideBox :: Monad m => Anchored a => Point -> a -> Diagram lab m ()+insideBox :: Monad m => Point -> Object -> Diagram lab m () insideBox p o = do   (o # SW) .<. p   p .<. (o # NE)@@ -247,16 +228,24 @@ -- | @autoLabel o i@ Layouts the label object @o@ at the given incidence -- vector. autoLabelObj :: Monad m => Box -> OVector -> Diagram lab m ()-autoLabelObj lab (OVector pt norm) = do-  pt `insideBox` lab-  minimize =<< orthoDist (lab#Center) (pt + norm)+autoLabelObj lab (OVector pt v) = do+  let normalVector :: Point' GExpr+      normalVector = normalize $ fromLinear <$> v+  -- label must touch the point+  tighten 10 $ pt `insideBox` lab+  -- go as far as possible in the normal direction+  maximize' $ dotProd (fromLinear <$> ((lab#Center) - pt)) normalVector+  -- don't stray from the normal line+  minimize' $ square $ dotProd (fromLinear <$> ((lab#Center) - pt)) (rotate90 normalVector)+  --  -- | @autoLabel o i@ Layouts the label object @o@ at the given incidence -- vector.-autoLabel :: Monad m => lab -> OVector -> Diagram lab m ()-autoLabel lab i = do-  o <- labelObj lab+autoLabel :: Monad m => String -> lab -> OVector -> Diagram lab m Object+autoLabel name lab i = do+  o <- label name lab   autoLabelObj o i+  return o  -- | @labeledEdge label source target@ labeledEdge :: Monad m => Object -> Object -> Box -> Diagram lab m ()@@ -266,7 +255,7 @@ -- Even higher-level primitives:  nodeDistance :: Expr-nodeDistance = 5+nodeDistance = constant 5  leftOf :: Monad m => Object -> Object -> Diagram lab m () a `leftOf` b = spread hdist nodeDistance [a,b]@@ -284,10 +273,10 @@ spread _ _ _ = return ()  -- | A node: a labeled circle-node :: Monad m => lab -> Diagram lab m Object-node lab = do-  l <- extend 4 <$> labelBox lab-  c <- draw $ circleShape+node :: Monad m => String -> lab -> Diagram lab m Object+node name lab = do+  l <- noDraw $ label name lab+  c <- circle name   l `fitsIn` c   l # Center .=. c # Center   return c@@ -298,8 +287,13 @@   edge src trg  -- | Bounding box of a number of anchored values-boundingBox :: (Monad m, Anchored a) => [a] -> Diagram lab m Object+boundingBox :: (Monad m) => [Object] -> Diagram lab m Object boundingBox os = do-  bx <- box+  bx <- box $ "boundingBox" ++ (show $ map objectName os)   mapM_ (`fitsIn` bx) os-  rectangleShape bx+  return bx++noOverlap :: Monad m => Object -> Diagram lab m Object+noOverlap o = do+  registerNonOverlap (o#SW) (o#NE)+  return o

@@ -4,24 +4,16 @@  import Graphics.Diagrams.Core import Graphics.Diagrams.Point-import Data.Traversable import Data.Foldable-import Data.Algebra--- import Data.Traversable--- import Data.Foldable import Graphics.Typography.Geometry.Bezier-import Graphics.Typography.Geometry.Bezier as Graphics.Diagrams.Point (Curve) -import Control.Applicative-import Data.List (sort,transpose)+import Data.List (sort) import Data.Maybe (listToMaybe)-import Prelude hiding (sum,mapM_,mapM,concatMap,maximum,minimum)+import Prelude hiding (sum,mapM_,mapM,concatMap,maximum,minimum,Num(..),(/)) import qualified Data.Vector.Unboxed as V import Algebra.Polynomials.Bernstein (restriction,Bernsteinp(..)) import Control.Lens (over, set, view) import Control.Monad.Reader (local)--unfreeze :: Functor t => t Constant -> t Expr-unfreeze = fmap constant+import Algebra.Classes  toBeziers :: FrozenPath -> [Curve] toBeziers EmptyPath = []@@ -29,15 +21,21 @@                             isCycle (last ss) = toBeziers' start (init ss ++ [StraightTo start])                           | otherwise = toBeziers' start ss +curveSegment :: FrozenPoint+                  -> FrozenPoint -> FrozenPoint -> FrozenPoint -> Curve curveSegment (Point xa ya) (Point xb yb) (Point xc yc) (Point xd yd) = bezier3 xa ya xb yb xc yc xd yd++lineSegment :: Point' Double -> Point' Double -> Curve lineSegment (Point xa ya) (Point xb yb) = line xa ya xb yb +-- | Convert a Path into a Curve toBeziers' :: FrozenPoint -> [Frozen Segment] -> [Curve] toBeziers' _ [] = [] toBeziers' start (StraightTo next:ss) = curveSegment start mid mid next : toBeziers' next ss   where mid = avg [start, next] toBeziers' p (CurveTo c d q:ss) = curveSegment p c d q : toBeziers' q ss +-- | Convert a Curve into a Path fromBeziers :: [Curve] -> FrozenPath fromBeziers [] = EmptyPath fromBeziers (Bezier cx cy t0 t1:bs) = case map toPt $ V.foldr (:) [] cxy of@@ -52,16 +50,16 @@ pathSegments EmptyPath = [] pathSegments (Path _ ss) = ss +isCycle :: Segment t -> Bool isCycle Cycle = True isCycle _  = False -frozenPointElim (Point x y) f = f x y--splitBezier (Bezier cx cy t0 t1) (u,v,_,_) = (Bezier cx cy t0 u, Bezier cx cy v t1)-+-- | @clipOne c0 cs@ return the part of c0 from its start to the point where it+-- intersects any element of cs. clipOne :: Curve -> [Curve] -> Maybe Curve clipOne b cutter = fmap firstPart $ listToMaybe $ sort $ concatMap (inter b) cutter   where firstPart t = fst $ splitBezier b t+        splitBezier (Bezier cx cy t0 t1) (u,v,_,_) = (Bezier cx cy t0 u, Bezier cx cy v t1)  -- | @cutAfter path area@ cuts the path after its first intersection with the @area@. cutAfter', cutBefore' :: [Curve] -> [Curve] -> [Curve]@@ -69,13 +67,14 @@ cutAfter' (b:bs) cutter = case clipOne b cutter of   Nothing -> b:cutAfter' bs cutter   Just b' -> [b']- -revBernstein (Bernsteinp n c) = Bernsteinp n (V.reverse c)++-- | Reverse a bezier curve revBeziers :: [Curve] -> [Curve] revBeziers = reverse . map rev   where rev (Bezier cx cy t0 t1) = (Bezier (revBernstein cx) (revBernstein cy) (1-t1) (1-t0))+        revBernstein (Bernsteinp n c) = Bernsteinp n (V.reverse c) -cutBefore' path area = revBeziers $ cutAfter' (revBeziers path) area+cutBefore' pth area = revBeziers $ cutAfter' (revBeziers pth) area  onBeziers :: ([Curve] -> [Curve] -> [Curve])              -> FrozenPath -> FrozenPath -> FrozenPath@@ -104,17 +103,18 @@   -- | Circle approximated with 4 cubic bezier curves-circle :: Point -> Expr -> Path-circle center r =      Path (pt r 0)-                         [CurveTo (pt r k) (pt k r) (pt 0 r),-                          CurveTo (pt (-k) r) (pt (-r) k) (pt (-r) 0),-                          CurveTo (pt (-r) (-k)) (pt (-k) (-r)) (pt 0 (-r)),-                          CurveTo (pt k (-r)) (pt r (-k)) (pt r 0),-                          Cycle]+circlePath :: Point -> Expr -> Path+circlePath center r =+  Path (pt r zero)+  [CurveTo (pt r k) (pt k r) (pt zero r),+   CurveTo (pt (negate k) r) (pt (negate r) k) (pt (negate r) zero),+   CurveTo (pt (negate r) (negate k)) (pt (negate k) (negate r)) (pt zero (negate r)),+   CurveTo (pt k (negate r)) (pt r (negate k)) (pt r zero),+   Cycle]  where k1 :: Constant        k1 = 4 * (sqrt 2 - 1) / 3        k = k1 *^ r-       pt x y = center ^+^ (Point x y)+       pt x y = center + (Point x y)   path :: Monad m => Path -> Diagram lab m ()@@ -135,6 +135,9 @@ draw :: Monad m => Diagram lab m a -> Diagram lab m a draw = stroke "black" +noDraw :: Monad m => Diagram lab m a -> Diagram lab m a+noDraw = using (set drawColor Nothing . set fillColor Nothing)+ noOutline :: PathOptions -> PathOptions noOutline = set drawColor Nothing @@ -171,4 +174,3 @@ dashDotted        o@PathOptions{..} = o { _dashPattern = [(3, 2), (_lineWidth, 2)] } denselyDashdotted o@PathOptions{..} = o { _dashPattern = [(3, 1), (_lineWidth, 1)] } looselyDashdotted o@PathOptions{..} = o { _dashPattern = [(3, 4), (_lineWidth, 4)] }-

@@ -6,6 +6,8 @@ import Graphics.Diagrams.Object import Graphics.Diagrams.Point import Control.Monad (forM_,when)+import Algebra.Classes+import Prelude hiding (Num(..),(/))  type Vec2 = Point' type Transform a = Iso a Constant@@ -18,14 +20,14 @@   draw {- using (set endTip ToTip) -} $ path $ polyline [origin,target]   when (not $ null $ labels) $ do     forM_ labels $ \(p,txt) -> do-      l0 <- labelObj txt-      let l = extend 3 (anchors l0)+      l0 <- label "axis" txt+      let l = extend (constant 3) l0       draw $ path $ polyline [l0 # anch, l # anch]       l # anch .=. Point (lint p (xpart origin) (xpart target))                          (lint p (ypart origin) (ypart target))  -- | @scale minx maxx@ maps the interval [minx,maxx] to [0,1]-scale :: forall b. Fractional b => b -> b -> Iso b b+scale :: forall b. Field b => b -> b -> Iso b b scale minx maxx = Iso (\x -> (x - minx) / (maxx - minx))                       (\x -> x * (maxx - minx) + minx) @@ -54,11 +56,11 @@ -- Input data in the [0,1] interval fits the box. scatterPlot :: Monad m => PlotCanvas a -> [Vec2 a] -> Diagram lab m () scatterPlot (bx,xform) input = forM_ (map (forward <$> xform <*>) input) $ \z -> do-  pt <- using (fill "black") $ circleShape+  pt <- using (fill "black") $ circle "plotMark"   width pt === constant 3   pt # Center .=. interpBox bx z -interpBox :: forall a. Anchored a => a -> Point' Constant -> Point' Expr+interpBox :: Object -> Point' Constant -> Point' Expr interpBox bx z = lint <$> z <*> bx#SW <*> bx#NE  -- | @functionPlot c n f@.@@ -112,7 +114,7 @@  preparePlot :: Monad m => Vec2 (ShowFct lab a) -> Vec2 (Transform a) -> Vec2 a -> Vec2 a -> Diagram lab m (PlotCanvas a) preparePlot showFct axesXform lo hi = do-  bx <- rectangleShape =<< box+  bx <- box "plotFrame"   axes bx marks   return (bx,xform)   where marks = mkSteps <$> xform <*> showFct <*> marks0

@@ -1,35 +1,45 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell, RankNTypes #-}  module Graphics.Diagrams.Point where  import Graphics.Diagrams.Core import Data.Foldable-import Control.Applicative import Data.List (transpose)-import Prelude hiding (sum,mapM_,mapM,concatMap,maximum,minimum)+import Prelude hiding (sum,mapM_,mapM,concatMap,maximum,minimum,Num(..),(/))+import Algebra.Classes+import Algebra.AD (sqrtE)  infix 4 .=. ------------------- Points +-- Points -- | A point in 2d space   type Point = Point' Expr --- | Orthogonal norm of a vector-orthonorm :: Monad m => Point -> Diagram lab m Expr-orthonorm (Point x y) =-  (+) <$> absoluteValue x <*> absoluteValue y+-- | Norm of a vector. Don't minimize this: the solver does not like functions+-- with non-continuous derivatives (at zero in this case).+norm :: Point' GExpr -> GExpr+norm p = sqrtE (sqNorm p) --- | Orthogonal distance between points.-orthoDist :: Monad m => Point -> Point -> Diagram lab m Expr-orthoDist p q = orthonorm (q-p)+normalize :: Point' GExpr -> Point' GExpr+normalize x = (one/norm x) *^ x +-- | Dot product+dotProd :: forall a. (Ring a) => Point' a -> Point' a -> a+dotProd (Point x y) (Point x' y') = x*x' + y*y'++-- | Squared norm of a vector+sqNorm :: forall a. (Ring a) => Point' a -> a+sqNorm p = dotProd p p+ -- | Rotate a vector 90 degres in the trigonometric direction.-rotate90, rotate180 :: Point -> Point+rotate90 :: forall a. Group a => Point' a -> Point' a rotate90 (Point x y) = Point (negate y) x -rotate180 = rotate90 . rotate90+-- | Rotate a vector 180 degres+rotate180 :: forall a. Group a => Point' a -> Point' a+rotate180 x = rotate90 . rotate90 $ x  xdiff,ydiff :: Point -> Point -> Expr xdiff p q = xpart (q - p)@@ -60,12 +70,3 @@ alignMatrix ls = do   forM_ ls alignHoriz   forM_ (transpose ls) alignVert-------------------------- Point objectives--southwards, northwards, westwards, eastwards :: Monad m => Point -> Diagram lab m ()-southwards (Point _ y) = minimize y-westwards (Point x _) = minimize x-northwards = southwards . negate-eastwards = westwards . negate

@@ -0,0 +1,171 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell, RankNTypes, GADTs, ImpredicativeTypes, DeriveFunctor, ScopedTypeVariables, ConstraintKinds #-}++module Graphics.Diagrams.Types where+import Algebra.Classes as AC+import Prelude hiding (sum,mapM_,mapM,concatMap,Num(..),(/),fromRational,recip,(/))+import Data.Traversable (foldMapDefault,fmapDefault)+import Control.Lens hiding (element)++type Constant = Double++type Frozen x = x Constant+type FrozenPoint = Frozen Point'+type FrozenPath = Frozen Path'+++------------------------------+-- Abstract algebra additions.+square :: forall a. Multiplicative a => a -> a+square x = x*x++(*-) :: Module Constant a => Constant -> a -> a+(*-) = (*^)+infixr 7 *-++-- | Average+avg :: Module Constant a => [a] -> a+avg xs = (1/fromIntegral (length xs)) *- add xs++------------+-- Types++data Pair a = Pair {pairFst :: a, pairSnd :: a}+  deriving (Functor)++instance Show a => Show (Pair a) where+  show (Pair x y) = show (x,y)++data Point' a = Point {xpart :: a, ypart :: a}+  deriving (Eq,Show,Functor)++instance Module k a => Module k (Point' a) where+  (*^) scalar = fmap (scalar *^)++instance Traversable Point' where+  traverse f (Point x y) = Point <$> f x <*> f y++instance Foldable Point' where+  foldMap = foldMapDefault++instance Applicative Point' where+  pure x = Point x x+  Point f g <*> Point x y = Point (f x) (g y)++instance Additive a => Additive (Point' a) where+  zero = Point zero zero+  Point x1 y1 + Point x2 y2 = Point (x1 + x2) (y1 + y2)++instance AbelianAdditive v => AbelianAdditive (Point' v) where++instance Group v => Group (Point' v) where+  negate (Point x y) = Point (negate x) (negate y)+  Point x1 y1 - Point x2 y2 = Point (x1 - x2) (y1 - y2)++++data Segment v = CurveTo (Point' v) (Point' v) (Point' v)+                   | StraightTo (Point' v)+                   | Cycle+                     -- Other things also supported by tikz:+                   --  Rounded (Maybe Constant)+                   --  HV point | VH point+  deriving (Show,Eq)+instance Functor Segment where+  fmap = fmapDefault++instance Foldable Segment where+  foldMap = foldMapDefault+instance Traversable Segment where+  traverse _ Cycle = pure Cycle+  traverse f (StraightTo p) = StraightTo <$> traverse f p+  traverse f (CurveTo c d q) = CurveTo <$> traverse f c <*> traverse f d <*> traverse f q+++data Path' a+  = EmptyPath+  | Path {startingPoint :: Point' a+         ,segments :: [Segment a]}+  deriving Show+-- mapPoints :: (Point' a -> Point' b) -> Path' a -> Path' b+instance Functor Path' where+  fmap = fmapDefault++instance Foldable Path' where+  foldMap = foldMapDefault+instance Traversable Path' where+  traverse _ EmptyPath = pure EmptyPath+  traverse f (Path s ss) = Path <$> traverse f s <*> traverse (traverse f) ss+++-- | Tikz decoration+newtype Decoration = Decoration String+++-- | Tikz line tip+data LineTip = ToTip | CircleTip | NoTip | StealthTip | LatexTip | ReversedTip LineTip | BracketTip | ParensTip++-- | Tikz color+type Color = String++-- | Tikz line cap+data LineCap = ButtCap | RectCap | RoundCap++-- | Tikz line join+data LineJoin = MiterJoin | RoundJoin | BevelJoin++-- | Tikz dash pattern+type DashPattern = [(Constant,Constant)]++-- | Path drawing options+data PathOptions = PathOptions+                     {_drawColor :: Maybe Color+                     ,_fillColor :: Maybe Color+                     ,_lineWidth :: Constant+                     ,_startTip  :: LineTip+                     ,_endTip    :: LineTip+                     ,_lineCap   :: LineCap+                     ,_lineJoin  :: LineJoin+                     ,_dashPattern :: DashPattern+                     ,_decoration :: Decoration+                     }+$(makeLenses ''PathOptions)++-- | Size of a box, in points. boxDepth is how far the baseline is+-- from the bottom. boxHeight is how far the baseline is from the top.+-- (These are TeX meanings)+data BoxSpec = BoxSpec {boxWidth, boxHeight, boxDepth :: Double}+             deriving (Show)++nilBoxSpec :: BoxSpec+nilBoxSpec = BoxSpec 0 0 0++data Backend lab m =+                 Backend {_tracePath :: PathOptions -> FrozenPath -> m ()+                         ,_traceLabel :: forall location (x :: * -> *). Monad x =>+                                                 (location -> (FrozenPoint -> m ()) -> x ()) -> -- freezer+                                                 (forall a. m a -> x a) -> -- embedder+                                                 location ->+                                                 lab -> -- label specification+                                                 x BoxSpec+                         }++$(makeLenses ''Backend)++data Env lab m = Env {_diaTightness :: Rational -- ^ Multiplicator to minimize constraints+                     ,_diaPathOptions :: PathOptions+                     ,_diaBackend :: Backend lab m}++$(makeLenses ''Env)++defaultPathOptions :: PathOptions+defaultPathOptions = PathOptions+  {_drawColor = Nothing+  ,_fillColor = Nothing+  ,_lineWidth = 0.4+  ,_startTip  = NoTip+  ,_endTip    = NoTip+  ,_lineCap   = ButtCap+  ,_lineJoin  = MiterJoin+  ,_dashPattern = []+  ,_decoration = Decoration ""+  }

@@ -1,5 +1,5 @@ name:                lp-diagrams-version:             1.0+version:             2.0 synopsis:            An EDSL for diagrams based based on linear constraints license:             AGPL-3 license-file:        LICENSE@@ -25,13 +25,21 @@                        Graphics.Diagrams.Plot,                        Graphics.Diagrams.Point,                        Graphics.Diagrams.Core,+                       Graphics.Diagrams.Types,                        Graphics.Diagrams.DerivationTrees,                        Graphics.Diagrams++                       Algebra.AD+                       Algebra.Linear+                       Algebra.Linear.GaussianElimination   build-depends:       base >=4.8 && < 666,+                       ad,                        lens >=4.12,                        text >=1.2 ,                        typography-geometry >=1.0 ,-                       glpk-hs >=0.3 ,+                       gasp,+                       nonlinear-optimization,+                       reflection,                        vector,                        polynomials-bernstein,                        mtl >=2.2 ,