2 files changed, 166 insertions, 4 deletions

diff --git a/Carpentry.hs b/Carpentry.hs
new file mode 100644
index 0000000..030eb86
--- /dev/null
+++ b/Carpentry.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Carpentry
+(
+  place
+, placeColored
+, placeAlong
+, placeTransformed
+, at
+, spreadEvenly
+, v3box
+, v3translate
+, writeTempSCAD
+, openTempSCAD
+, assemble
+, component
+  ) where
+
+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)
+
+v3translate :: (Vector (c, c, c), R3 t) => t c -> Model (c, c, c) -> Model (c, c, c)
+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 (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)
+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 c board coords = map boardAt coords
+  where
+    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)
+placeAlong ::
+  (R3 t1, R3 t2) =>
+  t2 Double
+  -> t1 Double
+  -> (t1 Double -> t1 Double)
+  -> ((t -> Const t t) -> t1 Double -> Const t (t1 Double))
+  -> (t -> Bool)
+  -> [Model (Double, Double, Double)]
+placeAlong board initial shift targ cond =
+  place board positions
+  where positions =
+          let next x =
+                let p = x & shift
+                in if cond (p ^. targ)
+                   then p : next p
+                   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 :: [(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 (\(_, 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)
+
+--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] ]
+
+
+
+-- 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)
+spreadEvenly boardWidth fillSpace boardCount =
+  let dist = (fillSpace - boardWidth) / fromIntegral (boardCount - 1)
+  in take boardCount $ iterate (+dist) 0
+
+writeTempSCAD :: String -> IO FilePath
+writeTempSCAD scadstr = writeSystemTempFile "genscad.scad" scadstr
+
+openTempSCAD :: String -> IO ProcessHandle
+openTempSCAD scadstr = do
+  fp <- writeTempSCAD scadstr
+  runCommand $ "openscad " ++ fp
diff --git a/shelves.hs b/shelves.hs
index cf935a0..b59bccf 100644
--- a/shelves.hs
+++ b/shelves.hs
@@ -1,6 +1,6 @@
 import           Graphics.OpenSCAD
 import           Linear.V3
-import           OpenSCAD.Carpentry
+import           Carpentry
 import           System.Process
 
 -- the minimum paramaters to describe a shelf; the width and depth of a shelf,
@@ -14,9 +14,8 @@ data Shelf = Shelf {
 } deriving (Show)
 
 myShelf :: Shelf
-myShelf = Shelf { width = 12*4, depth = 12, boardThickness = 1,
-                  shelfHeights = [15, 8, 8, 8] }
-
+myShelf = Shelf { width = 12*80000, depth = 48, boardThickness = 1,
+                  shelfHeights = [36, 36, 36]  }
 
 calcShelfHeights :: Shelf -> [Double]
 calcShelfHeights s = scanl (+) 0 [h + (boardThickness s)|h <- (shelfHeights s)]