Added new interface `assemble` and `component` to OpenSCAD.Carpentry;

reimplemented shelves.hs with above interface. (This interface broke the ability
to change board colors; a fix is coming up)

2 files changed, 149 insertions, 4 deletions

diff --git a/OpenSCAD/Carpentry.hs b/OpenSCAD/Carpentry.hs
index 7191781..060754d 100644
--- a/OpenSCAD/Carpentry.hs
+++ b/OpenSCAD/Carpentry.hs
@@ -4,12 +4,15 @@ module OpenSCAD.Carpentry
   place
 , placeColored
 , placeAlong
+, placeTransformed
 , at
 , spreadEvenly
 , v3box
 , v3translate
 , writeTempSCAD
 , openTempSCAD
+, assemble
+, component
   ) where
 
 import           Control.Applicative
@@ -18,6 +21,10 @@ 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
 
 v3box :: R3 t => t Double -> Model3d
 v3box v = box (v ^. _x) (v ^. _y) (v ^. _z)
@@ -27,11 +34,14 @@ v3translate v m = translate (v ^. _x, v ^. _y, v ^. _z) m
 --  ^ doesn't work ??
 
 place :: (R3 t1, R3 t2) => t2 Double -> [t1 Double] -> [Model (Double, Double, Double)]
-place board coords = map boardAt coords
+place board coords = map (placeOne board) coords
   where
     boardAt p = translate (p ^. _x, p ^. _y, p ^. _z) $ v3box board
 --    boardAt p = v3translate p $ v3box board
 
+placeOne b c = translate (c ^. _x, c ^. _y, c ^. _z) $ v3box b
+
+placeTransformed t r = t $ place r
 
 -- intended usage: place (V3 2 4 16) $ at [0] [0,4..(20*12)] [0]
 -- (which would, e.g., place 2x4 planks next to each other for 20 feet (e.g., floor boards)
@@ -43,7 +53,6 @@ placeColored rgb board coords = map boardAt coords
   where
     boardAt p = color rgb $ 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)
 placeAlong ::
@@ -64,6 +73,94 @@ placeAlong board initial shift targ cond =
                    else []
           in initial : next initial
 
+
+
+-- data CarpentryProject = CarpentryProject
+--   {   dimensions :: V3 Double
+--     , components :: [ProjectCompnent]
+--   } deriving (Show)
+
+-- data Component = Component {
+--     name :: String,
+--   , dim :: V3 Double
+--   , 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 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
+    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)
+
+-- 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
 -- e.g., if you want to have a 20x20 space and want support beams every 16":
 -- spreadEvenly 2 20 (20*12/16)
diff --git a/shelves.hs b/shelves.hs
index c560cf4..16f029f 100644
--- a/shelves.hs
+++ b/shelves.hs
@@ -14,8 +14,8 @@ data Shelf = Shelf {
 } deriving (Show)
 
 myShelf :: Shelf
-myShelf = Shelf { width = 36, depth = 8, boardThickness = 1,
-                  shelfHeights = [12, 12, 10, 10, 6, 6, 6] }
+myShelf = Shelf { width = 12*4, depth = 12, boardThickness = 1,
+                  shelfHeights = [15, 8, 8, 8] }
 
 
 calcShelfHeights :: Shelf -> [Double]
@@ -54,6 +54,52 @@ modelShelf'' s =
         shelfBoard = V3 (width s) (depth s) (boardThickness s)
         shelfZs = scanl (+) 0 [h + (boardThickness s)|h <- (shelfHeights s)]
 
+data ModeledShelf = ModeledShelf {
+  shelfDimensions :: V3 Double,
+  shelfPositions :: [V3 Double],
+  sideDimensions :: V3 Double,
+  sidePositions :: [V3 Double],
+  rendered :: [Model3d],
+  cutlist :: String
+} deriving (Show)
+
+modelShelf''' :: Shelf -> ModeledShelf
+modelShelf''' s =
+  ModeledShelf { shelfDimensions = shelfB,
+                 shelfPositions = shelfP,
+                 sideDimensions = sideB,
+                 sidePositions = sideP,
+                 rendered = placeColored red  sideB sideP ++
+                            placeColored blue shelfB shelfP,
+                 cutlist = cutlist
+               }
+  where shelfHeight = sum (shelfHeights s) + (boardThickness s) *
+                  (fromIntegral (length $ shelfHeights s) + 1)
+        sideB =  V3 (boardThickness s) (depth s) shelfHeight
+        sideP = at [0, boardThickness s + width s] [0] [0]
+        shelfB = V3 (width s) (depth s) (boardThickness s)
+        shelfP = at [(boardThickness s)] [0] $ scanl (+) 0 [h + (boardThickness s)|h <- (shelfHeights s)]
+        cutlist = "Shelves: (" ++ (show (length shelfP)) ++ ") @ "
+                  ++ (show shelfB) ++
+                  "\nSides: (2) @ " ++ (show sideB)
+
+assembleShelf s = assemble [shelves, sides]
+  where
+    shelfHeight =
+      sum (shelfHeights s) +
+      (boardThickness s) * (fromIntegral (length $ shelfHeights s) + 1)
+    sides =
+      let sideB = V3 (boardThickness s) (depth s) shelfHeight
+          sideP = at [0, boardThickness s + width s] [0] [0]
+       in component "sides" 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
+
 
 shelf :: String
 shelf = renderL $ modelShelf myShelf
@@ -62,5 +108,7 @@ shelf' = renderL $ modelShelf' myShelf
 shelf'' :: String
 shelf'' = renderL $ modelShelf'' myShelf
 
+(cuts, model) = assembleShelf myShelf
+
 main :: IO ProcessHandle
 main = openTempSCAD $ shelf''