From 7f95620de4c0a5744084ac4261f804dd0c10ed80 Mon Sep 17 00:00:00 2001 From: Steven Date: Wed, 12 Jun 2019 20:33:56 -0400 Subject: Added support for colors --- OpenSCAD/Carpentry.hs | 151 +++++++++++++++++++++----------------------------- shelves.hs | 10 ++-- 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 number of boards (of the width ) in 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 -- cgit v1.2.3