Added support for colors

2 files changed, 70 insertions, 91 deletions

diff --git a/OpenSCAD/Carpentry.hs b/OpenSCAD/Carpentry.hs
index b6d1e73..aeb9ede 100644
--- a/OpenSCAD/Carpentry.hs
+++ b/OpenSCAD/Carpentry.hs
@@ -15,16 +15,17 @@ module OpenSCAD.Carpentry
 , component
   ) where
 
-import           Control.Applicative
-import           Control.Lens        hiding (at)
-import           Graphics.OpenSCAD
-import           Linear.V3
-import           System.IO.Temp
-import           System.Process
-import           Data.List
-import           Data.Functor
-import           Data.Maybe
-import           Data.Either
+import Control.Applicative
+import Control.Lens hiding (at)
+import Data.Colour.RGBSpace
+import Data.Either
+import Data.Functor
+import Data.List
+import Data.Maybe
+import Graphics.OpenSCAD
+import Linear.V3
+import System.IO.Temp
+import System.Process
 
 v3box :: R3 t => t Double -> Model3d
 v3box v = box (v ^. _x) (v ^. _y) (v ^. _z)
@@ -49,9 +50,9 @@ at :: Applicative f => f a -> f a -> f a -> f (V3 a)
 at = liftA3 V3
 --at x y z = V3 <$> x <*> y <*> z -- same as above
 
-placeColored rgb board coords = map boardAt coords
+placeColored c board coords = map boardAt coords
   where
-    boardAt p = color rgb $ translate (p ^. _x, p ^. _y, p ^. _z) $ v3box board
+    boardAt p = color c $ translate (p ^. _x, p ^. _y, p ^. _z) $ v3box board
 
 -- deprecated due to the superiority of using place in conjunction with at
 -- placeAlong (V3 2 4 16) (V3 0 0 0) (_x +~ 4) _x (<= 20)
@@ -83,91 +84,67 @@ placeAlong board initial shift targ cond =
 -- data Component = Component {
 --     name :: String,
 --   , dim :: V3 Double
---   , orient :: 
+--   , orient ::
 --                            }
 -- assemble
 -- assemble [   component "shelves" (V3 1 8 36) _xyz $ at [0] [0,12,24,36] [0]
 --            , component "sides" (V3 1 8 40) _xyz $ at [0] [0,36] [0] ]
 
+assemble :: [(String, String, V3 Double,
+         (V3 Double -> Const (V3 Double) (V3 Double))
+         -> V3 Double -> Const (V3 Double) (V3 Double),
+         [V3 Double])] -> (String, [Model3d])
 assemble c = (cutlist, model)
   where
-    model = concatMap (\(_, b, o, p) -> place (b ^. o) p) c
-    cutlist = putStrLn $ intercalate "\n" $ map tocut c
-    tocut (n, b, _, p) = n ++ " (" ++ (show $ length p) ++ ") @ " ++ v3toStr b
+    model = concatMap (\(_, c, b, o, p) -> placeColored (safeColor c) (b ^. o) p) c
+    safeColor :: String -> Colour Double
+    safeColor = runIdentity . readColourName
+    cutlist = intercalate "\n" $ map tocut c
+    tocut (n, c, b, _, p) = n ++ " (" ++ show (length p) ++ ", " ++ c ++ ") @ " ++ v3toStr b
     v3toStr c = show (c ^. _x) ++ " x " ++ show (c ^. _y) ++ " x " ++ show (c ^. _z)
 
--- assemble' c = (cutlist, model)
---   where
---     model = let placeBoard b p = translate (p ^. _x, p ^. _y, p ^. _z) $ v3box b
---       in concatMap (\(_, b, o, p, tf) placeBoard 
---       boardAt p = 
-component name dim orient pos = (name, dim, orient, pos)
+--component :: a -> b -> c -> d -> e -> (a, b, c, d, e)
+--component :: a -> b -> c -> d -> e -> (a, b, c, d, e)
+-- component :: String
+--           -> String
+--           -> V3 Double
+--           -> ((f -> Const f f) -> V3 Double -> Const f (V3 Double))
+--           -> [V3 Double]
+--           -> (String, String, V3 Double,
+--                (f -> Const f f) ->
+--                V3 Double -> Const f (V3 Double), [V3 Double], f)
+
+-- c :: ([Char], [Char], V3 Integer,
+--       (V3 a -> ghc-prim-0.5.3:GHC.Types.Any (V3 a))
+--       -> ghc-prim-0.5.3:GHC.Types.Any a
+--       -> ghc-prim-0.5.3:GHC.Types.Any (ghc-prim-0.5.3:GHC.Types.Any a),
+--       [V3 Integer])
+-- component :: (String, String, V3 Double,
+--                (V3 Double -> Const (V3 Double) (V3 Double))
+--                 -> V3 Double -> Const (V3 Double) (V3 Double), [V3 Double])
+-- component :: String -> String, V3 Integer,
+--       (V3 Integer -> Const (V3 Integer) (V3 Integer))
+--       -> V3 Integer -> Const (V3 Integer) (V3 Integer),
+--       [V3 Integer])
+--component name col dim orient pos = (name, col, dim, orient, pos, dim ^. orient)
+
+--component name col dim orient pos = (name, col, dim, orient, pos, dim ^. orient)
+component
+  :: String
+     -> String
+     -> V3 Double
+     -> ((V3 Double -> Const (V3 Double) (V3 Double))
+         -> V3 Double -> Const (V3 Double) (V3 Double))
+     -> [V3 Double]
+     -> (String, String, V3 Double,
+         (V3 Double -> Const (V3 Double) (V3 Double))
+         -> V3 Double -> Const (V3 Double) (V3 Double),
+         [V3 Double])
+component name col dim orient pos = (name, col, dim, orient, pos)
+--component name col dim orient pos = (name :: String, col :: String, dim :: V3 Double, orient, pos :: [V3 Double])
+
+ass = assemble [component "shelves" "neh" (V3 1 8 36) _xyz [V3 0 0 0, V3 0 0 10] ]
 
---data CName = String
-
---data Component name dim pos = ( 
-
--- data Component = Component {
---     name :: String,
---   , dim :: V3 Double
---   , orient :: 
-
--- ass :: 
--- ass v = show v
-
--- maybeMore :: Either a [a]
--- maybeMore x = either [x] x x
-
--- count :: Either a0 [a1] -> Int
--- count (Left a) = length [a]
--- count (Right b) = length b
-
--- maybeMore :: Maybe [a] -> [a]
--- maybeMore x = [x]
--- maybeMore [x] = [x]
-
--- maybeMore :: Maybe [a] -> [a]
--- maybeMore x = fromMaybe
-
-
-
--- data Many = Left [a] | Right b
--- maybeMany :: Many -> Int
--- maybeMany Left x = x
--- maybeMany Right x = [x]
-
--- data AlwaysMany = FromOne a | AlreadyMany [a]
--- alwaysMany (FromOne x) = [x]
--- alwaysMany (AlreadyMany x) = x
-
--- data AlwaysMany a b = Left a | Right b
--- data Many a = Either [a]
-
--- alwaysMany :: Many a -> Int
--- alwaysMany (Right x) = x
-
--- type OnceOne a = [a]
--- type AlreadyMany a = [a]
--- data AlwaysMany a = OnceOne a | AlreadyMany a deriving (Foldable, Eq, Ord)
-
--- alwaysMany :: AlwaysMany a -> Int
--- alwaysMany x = length x
-
-
--- data AlwaysMany a = Maybe [a] | Just [a]
--- alwaysMany :: AlwaysMany a -> [a]
--- alwaysMany x = x
-
-
--- count x
--- --  where y = if isLeft x then [x] else x
---   | isLeft x = length [x]
---   | otherwise = length x
-
--- which :: Either String Int -> String
--- which x = either show show x
--- which Left x = "string"
--- which Right x = "int"
 
 
 -- evenly spread <boardCount> number of boards (of the width <boardWidth>) in <span> space
diff --git a/shelves.hs b/shelves.hs
index 16f029f..cf935a0 100644
--- a/shelves.hs
+++ b/shelves.hs
@@ -91,14 +91,14 @@ assembleShelf s = assemble [shelves, sides]
     sides =
       let sideB = V3 (boardThickness s) (depth s) shelfHeight
           sideP = at [0, boardThickness s + width s] [0] [0]
-       in component "sides" sideB _xyz sideP
+      in component "sides" "blue" sideB _xyz sideP
     shelves =
       let shelfB = V3 (width s) (depth s) (boardThickness s)
           shelfP =
             let pz =
                   scanl (+) 0 [h + (boardThickness s) | h <- (shelfHeights s)]
              in at [(boardThickness s)] [0] pz
-       in component "shelves" shelfB _xyz shelfP
+       in component "shelves" "red" shelfB _xyz shelfP
 
 
 shelf :: String
@@ -108,7 +108,9 @@ shelf' = renderL $ modelShelf' myShelf
 shelf'' :: String
 shelf'' = renderL $ modelShelf'' myShelf
 
-(cuts, model) = assembleShelf myShelf
+mesh = assembleShelf myShelf
 
 main :: IO ProcessHandle
-main = openTempSCAD $ shelf''
+main = let (cuts, model) = assembleShelf myShelf
+       in do putStrLn cuts
+             openTempSCAD $ renderL model