Commit e5b482 wip

4 files Authored and Committed by Richard Marko 2 years ago
wip

    
  1 @@ -1,7 +1,7 @@
  2   -- | Export model generation.
  3   module Language.Mecha.Export
  4 -   ( povray
  5 -   , openSCAD
  6 +   ( --povray
  7 +    openSCAD
  8     ) where
  9   
 10   import Text.Printf
 11 @@ -9,46 +9,47 @@
 12   import Language.Mecha.Solid
 13   
 14   -- Generates a POV-Ray model.
 15 - povray :: Solid -> String
 16 - povray a = unlines
 17 -   [ "// Generated by Mecha (https://github.com/tomahawkins/mecha)"
 18 -   , ""
 19 -   , solid a
 20 -   , ""
 21 -   ]
 22 -   where
 23 - 
 24 -   solid :: Solid -> String
 25 -   solid a = case a of
 26 -     Primitive t (r, g, b, o) a -> printf "%s { %s\n%s%s}\n" a1 a2 (indent $ concatMap transform t) (indent color)
 27 -       where
 28 -       color :: String
 29 -       color = printf "pigment { rgbt <%f, %f, %f, %f> }\n" r g b (1 - o)
 30 -       a1 :: String
 31 -       a2 :: String
 32 -       (a1, a2) = case a of
 33 -         Sphere d     -> ("sphere", printf "<0, 0, 0>, %f" (d / 2))
 34 -         Cone bd td h -> ("cone",   printf "<0, 0, 0>, %f <0, %f, 0>, %f" (bd / 2) h (td / 2))
 35 -         Box (x1, x2) (y1, y2) (z1, z2) -> ("box", printf "<%f, %f, %f>, <%f, %f, %f>" xmin zmin ymin xmax zmax ymax)
 36 -           where
 37 -           xmin = min x1 x2
 38 -           xmax = max x1 x2
 39 -           ymin = min y1 y2
 40 -           ymax = max y1 y2
 41 -           zmin = min z1 z2
 42 -           zmax = max z1 z2
 43 - »       Torus d1 d2  -> ("torus", printf "%f, %f" (d1 / 2) (d2 / 2))
 44 -     Union        a b   -> printf "merge        {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
 45 -     Intersection a b   -> printf "intersection {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
 46 -     Difference   a b   -> printf "difference   {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
 47 - 
 48 -   transform :: Transform -> String
 49 -   transform a = case a of
 50 -     Scale (x, y, z) -> printf "scale <%f, %f, %f>\n" x z y
 51 -     Move  (x, y, z) -> printf "translate <%f, %f, %f>\n" x z y
 52 -     RotateX a       -> printf "rotate <%f, 0, 0>\n" (-a * 180 / pi)
 53 -     RotateY a       -> printf "rotate <0, 0, %f>\n" (-a * 180 / pi)
 54 -     RotateZ a       -> printf "rotate <0, %f, 0>\n" (-a * 180 / pi)
 55 + --povray :: Solid -> String
 56 + --povray a = unlines
 57 + --  [ "// Generated by Mecha (https://github.com/tomahawkins/mecha)"
 58 + --  , ""
 59 + --  , solid a
 60 + --  , ""
 61 + --  ]
 62 + --  where
 63 + --
 64 + --  solid :: Solid -> String
 65 + --  solid a = case a of
 66 + --    Prim t a -> printf "%s { %s\n%s}\n" a1 (indent $ concatMap transform t)
 67 + --      where
 68 + --      --color :: String
 69 + --      --color = printf "pigment { rgbt <%f, %f, %f, %f> }\n" r g b (1 - o)
 70 + --      a1 :: String
 71 + --      a2 :: String
 72 + --      (a1, a2) = case a of
 73 + --        Sphere d     -> ("sphere", printf "<0, 0, 0>, %f" (d / 2))
 74 + --        Cone bd td h -> ("cone",   printf "<0, 0, 0>, %f <0, %f, 0>, %f" (bd / 2) h (td / 2))
 75 + --        Box (x1, x2) (y1, y2) (z1, z2) -> ("box", printf "<%f, %f, %f>, <%f, %f, %f>" xmin zmin ymin xmax zmax ymax)
 76 + --          where
 77 + --          xmin = min x1 x2
 78 + --          xmax = max x1 x2
 79 + --          ymin = min y1 y2
 80 + --          ymax = max y1 y2
 81 + --          zmin = min z1 z2
 82 + --          zmax = max z1 z2
 83 + --»       Torus d1 d2  -> ("torus", printf "%f, %f" (d1 / 2) (d2 / 2))
 84 + --    Union        a b   -> printf "merge        {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
 85 + --    Intersection a b   -> printf "intersection {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
 86 + --    Difference   a b   -> printf "difference   {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
 87 + --
 88 + --  transform :: Transform -> String
 89 + --  transform a = case a of
 90 + --    Scale (x, y, z) -> printf "scale <%f, %f, %f>\n" x z y
 91 + --    Move  (x, y, z) -> printf "translate <%f, %f, %f>\n" x z y
 92 + --    RotateX a       -> printf "rotate <%f, 0, 0>\n" (-a * 180 / pi)
 93 + --    RotateY a       -> printf "rotate <0, 0, %f>\n" (-a * 180 / pi)
 94 + --    RotateZ a       -> printf "rotate <0, %f, 0>\n" (-a * 180 / pi)
 95 + --    Background      -> ""
 96   
 97   -- Generates an OpenSCAD model.
 98   openSCAD :: Solid -> String
 99 @@ -65,22 +66,26 @@
100       Union        a b   -> printf "union()        {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
101       Intersection a b   -> printf "intersection() {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
102       Difference   a b   -> printf "difference()   {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
103 -     Primitive t (r, g, b, o) p -> printf "color([%f, %f, %f, %f]) %s\n" r g b o $ transform $ reverse t
104 -       where
105 +     Trans t a          -> printf "%s %s" (transform [t]) (solid a)
106 +     Prim pp p -> printf "%s\n" $ primitive p pp
107 +     where
108         transform :: [Transform] -> String
109         transform a = case a of
110 -         [] -> primitive p
111 +         [] -> "" -- primitive p
112           Scale (x, y, z) : rest -> printf "scale ([%f, %f, %f]) %s"     x y z          $ transform rest
113           Move  (x, y, z) : rest -> printf "translate ([%f, %f, %f]) %s" x y z          $ transform rest
114           RotateX a       : rest -> printf "rotate (%f, [1, 0, 0]) %s"   (a * 180 / pi) $ transform rest
115           RotateY a       : rest -> printf "rotate (%f, [0, 1, 0]) %s"   (a * 180 / pi) $ transform rest
116           RotateZ a       : rest -> printf "rotate (%f, [0, 0, 1]) %s"   (a * 180 / pi) $ transform rest
117 +         Background      : rest -> printf "%% %s" $ transform rest
118 +         Debug           : rest -> printf "# %s" $ transform rest
119 +         --Color (r, g, b, a) : rest -> printf "color([%f, %f, %f, %f]) %s" r g b a $ transform rest
120   
121 -       primitive :: Primitive -> String
122 -       primitive a = case a of
123 -         Sphere d     -> printf "sphere(r = %f, $fn = 100);\n" (d / 2)
124 -         Cone bd td h -> printf "cylinder(h = %f, r1 = %f, r2 = %f, center = false, $fn = 100);\n" h (bd / 2) (td / 2)
125 -         Box (x1, x2) (y1, y2) (z1, z2) -> printf "translate ([%f, %f, %f]) cube(size = [%f, %f, %f], center = false);\n" xmin ymin zmin (xmax - xmin) (ymax - ymin) (zmax - zmin)
126 +       primitive :: Primitive -> [Property] -> String
127 +       primitive a pp = case a of
128 +         Sphere d     -> printf "sphere(r = %f, %s);\n" (d / 2) (props pp)
129 +         Cone bd td h -> printf "cylinder(h = %f, r1 = %f, r2 = %f %s);\n" h (bd / 2) (td / 2) (props pp)
130 +         Box (x1, x2) (y1, y2) (z1, z2) -> printf "translate ([%f, %f, %f]) cube(size = [%f, %f, %f], %s);\n" xmin ymin zmin (xmax - xmin) (ymax - ymin) (zmax - zmin) (props pp)
131             where
132             xmin = min x1 x2
133             xmax = max x1 x2
134 @@ -90,6 +95,11 @@
135             zmax = max z1 z2
136           Torus d1 d2 -> printf "rotate_extrude($fn = 100) translate([%f, 0, 0]) circle(%f, $fn = 100);" (d1 / 2) (d2 / 2)
137   
138 + props :: [Property] -> String
139 + props [] = ""
140 + props (Fn x : rest) = printf ", $fn=%f %s" x $ props rest
141 + 
142 + 
143   indent :: String -> String
144   indent a = unlines [ "\t" ++ l | l <- lines a ]
145   
 1 @@ -2,6 +2,7 @@
 2     ( Solid     (..)
 3     , Primitive (..)
 4     , Transform (..)
 5 +   , Property   (..)
 6     , sphere
 7     , cone
 8     , box
 9 @@ -16,18 +17,29 @@
10   import Language.Mecha.Types
11   
12   data Solid
13 -   = Primitive [Transform] Color Primitive
14 +   = Prim [Property] Primitive
15     | Union        Solid Solid
16     | Intersection Solid Solid
17     | Difference   Solid Solid
18 -   deriving Eq
19 +   | Trans        Transform Solid
20 +   deriving (Eq, Show)
21 + 
22 + instance Num Solid where
23 +   (+) = Union
24 +   --(-) = Difference
25 +   (-) a b = Difference a (moveZ (-0.01) $ scaleZ (1.002) b)
26 +   (*) = Intersection
27   
28   data Primitive
29     = Sphere Double                -- ^ Diameter.
30     | Cone   Double Double Double  -- ^ Bottom diameter, top diameter, height.
31     | Box (Double, Double) (Double, Double) (Double, Double)  -- ^ (x min, x max) (y min, ymax) (z min, z max).
32     | Torus  Double Double         -- ^ Major diameter, minor diameter.
33 -   deriving Eq
34 +   deriving (Eq, Show)
35 + 
36 + data Property
37 +   = Fn Double
38 +   deriving (Eq, Show)
39   
40   data Transform
41     = Scale (Vector)
42 @@ -35,20 +47,33 @@
43     | RotateX Double
44     | RotateY Double
45     | RotateZ Double
46 -   deriving Eq
47 +   | Background
48 +   | Debug
49 +   | Color (Double, Double, Double, Double)
50 +   deriving (Eq, Show)
51 + 
52 + setProp :: Property -> Solid -> Solid
53 + setProp p a = case a of
54 +   Prim         a b   -> Prim (a ++ [p]) b
55 +   Union        a b     -> Union         (setProp p a) (setProp p b)
56 +   Intersection a b     -> Intersection  (setProp p a) (setProp p b)
57 +   Difference   a b     -> Difference    (setProp p a) (setProp p b)
58 +   Trans        t a     -> Trans t (setProp p a)
59   
60   transform :: Transform -> Solid -> Solid
61 - transform t a = case a of
62 -   Primitive    a b c   -> Primitive (a ++ [t]) b c
63 -   Union        a b     -> Union         (transform t a) (transform t b)
64 -   Intersection a b     -> Intersection  (transform t a) (transform t b)
65 -   Difference   a b     -> Difference    (transform t a) (transform t b)
66 + transform t a = Trans t a
67 + 
68 + instance Modifiable Solid where
69 +   bg = transform Background
70 +   dbg = transform Debug
71 +   fn c a = setProp (Fn c) a
72   
73   instance Moveable Solid where
74     move a    = transform $ Move a
75     rotateX a = transform $ RotateX a
76     rotateY a = transform $ RotateY a
77     rotateZ a = transform $ RotateZ a
78 +   rotZ a = transform $ RotateZ (2 * pi / 360.0 * a)
79   
80   instance Scaleable Solid where
81     scale a   = transform $ Scale a
82 @@ -59,14 +84,10 @@
83     difference   = Difference
84   
85   instance Colorable Solid where
86 -   color c a = case a of
87 -     Primitive    a _ b   -> Primitive a c b
88 -     Union        a b     -> Union         (color c a) (color c b)
89 -     Intersection a b     -> Intersection  (color c a) (color c b)
90 -     Difference   a b     -> Difference    (color c a) (color c b)
91 +   color = transform . Color
92   
93   primitive :: Primitive -> Solid
94 - primitive = Primitive [] (0.5, 0.5, 0.5, 1)
95 + primitive = Prim []
96   
97   -- | A sphere with diameter, centered at origin.
98   sphere :: Double -> Solid
 1 @@ -1,5 +1,6 @@
 2   module Language.Mecha.Types
 3     ( Vector, Vertex, Normal, Color
 4 +   , Modifiable  (..)
 5     , Moveable  (..)
 6     , Scaleable (..)
 7     , Colorable (..)
 8 @@ -19,11 +20,17 @@
 9   type Normal = Vector
10   type Color  = (Double, Double, Double, Double)
11   
12 + class Modifiable a where
13 +   bg :: a -> a
14 +   dbg :: a -> a
15 +   fn :: Double -> a -> a
16 + 
17   class Moveable a where
18     move    :: Vector -> a -> a
19     rotateX :: Double -> a -> a
20     rotateY :: Double -> a -> a
21     rotateZ :: Double -> a -> a
22 +   rotZ    :: Double -> a -> a
23   
24   moveX :: Moveable a => Double -> a -> a
25   moveX a = move (a, 0, 0)
 1 @@ -0,0 +1,71 @@
 2 + {-# LANGUAGE FlexibleInstances #-}
 3 + module Main where
 4 + 
 5 + import Language.Mecha
 6 + import System.Process
 7 + 
 8 + cyl r h = cylinder (r*2) h
 9 + cCyl r h = moveZ (-h/2.0) $ cylinder (r*2) h
10 + c x y z = box (-x/2.0, x/2.0) (-y/2.0, y/2.0) (-z/2.0, z/2.0)
11 + cf x y z = box (-x/2.0, x/2.0) (-y/2.0, y/2.0) (0, z)
12 + --bg = color (0.1, 0.1, 0.1, 1)
13 + 
14 + encInnerR = 4.9
15 + anchorR = 2.5
16 + anchorO = 15.0
17 + axisR = 2.75
18 + 
19 + encoder = cyl 27 2
20 + 
21 + 
22 + --holder h = difference (unions body) (union axis fixhole)
23 + holder h = (unions body) - (axis + fixhole)
24 + 
25 +   where
26 +     body = [ cyl encInnerR h2
27 +            , cf (anchorO * 2) 4 h
28 +            , cf 4 (anchorO * 2) h
29 +            ] ++ [ rotateZ (pi / 2 * (fromInteger i)) $ moveX anchorO $ cyl anchorR h2 | i <- [0..4] ] 
30 + 
31 +     axis = cCyl axisR 100
32 +     fixhole = moveZ 3 $ rotateX (pi / 2.0) $ rotateY (pi / 4.0) $ cCyl 1.4 100
33 +     h2 = h + 2
34 + 
35 + --mcsg = union (color (0.3, 0.3, 0.8, 1) $ holder 6) (bg encoder)
36 + 
37 + mcsg' = unions [
38 +     moveY 40 $ b - c
39 +   , (a - (b - c))
40 +   , bg $ (a + b + c)
41 +   ]
42 +   where
43 +     a = rotateZ (pi/2.0) $ moveX 5 $ cyl 10 10
44 +     b = rotateZ (pi/2.0 * 2) $ moveX 5 $ cyl 10 10
45 +     c = moveX 5 $ cyl 10 10
46 + 
47 + honeyR = 1.0
48 + honeyT = 1.1
49 + honeySD = 2 * (sqrt $ (honeyR ** 2) - ((honeyR / 2.0) ** 2))
50 + 
51 + honeyOne h = fn 6 $ cCyl honeyR h
52 + honeyPattern x y obj = unions [
53 +     moveY (jy * yO) $ moveX (ix * xO) $ objs
54 +       | ix <- [-x/2 .. x/2]
55 +       , jy <- [-y/2 .. y/2]
56 +     ]
57 +   where
58 +     objs = obj + (rotZ 60 $ moveY yO obj)
59 +     xO = 2 * honeyR + honeyR + 2 * (sqrt $ honeyT ** 2 - (honeyT / 2) ** 2)
60 +     yO = honeySD + honeyT
61 + honeyComb x y h = honeyPattern x y (honeyOne h)
62 + 
63 + mcsg = (cyl 100 4) - (honeyComb 100 100 10)
64 + 
65 + main :: IO ()
66 + main = do
67 +   putStrLn $ show mcsg
68 + 
69 +   putStrLn "Writing file csg.scad.  Opening with OpenSCAD ..."
70 +   writeFile "csg.scad" $ openSCAD $ scaleAll 10 $ mcsg
71 +   --readProcess "openscad" ["csg.scad"] ""
72 +   return ()