1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
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
|