From 4178e86451a08c1963e58cbaac78c706d0fdf671 Mon Sep 17 00:00:00 2001 From: Steven Date: Tue, 25 Jun 2019 21:57:41 -0400 Subject: moved OpenSCAD.Carpentry to Carpentry --- Carpentry.hs | 163 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ shelves.hs | 7 ++- 2 files changed, 166 insertions(+), 4 deletions(-) create mode 100644 Carpentry.hs 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 number of boards (of the width ) in 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)] -- cgit v1.2.3