Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

forked

  • Loading branch information...
commit 4091bbfc09d6cf354d4d6b491da1a5ba44c5b471 1 parent fb38f99
Paolo Veronelli authored

Showing 34 changed files with 124 additions and 1,063 deletions. Show diff stats Hide diff stats

  1. +11 0 Language/HOpenSCAD.hs
  2. BIN  Language/HOpenSCAD/.Types.hs.swp
  3. 0  Language/{Mecha → HOpenSCAD}/Examples/CSG.hs
  4. +6 48 Language/{Mecha → HOpenSCAD}/Export.hs
  5. +7 2 Language/{Mecha → HOpenSCAD}/Solid.hs
  6. +13 1 Language/{Mecha → HOpenSCAD}/Types.hs
  7. +0 11 Language/Mecha.hs
  8. +0 14 MechaExamples.hs
  9. +4 4 README.md
  10. +0 117 attic/Assembly.hs
  11. +0 246 attic/Mesh.hs
  12. +0 218 attic/Octree.hs
  13. +0 31 attic/OpenGL.hs
  14. +0 20 attic/Primitives.hs
  15. +0 247 attic/Viewer.hs
  16. +0 62 attic/Visual.hs
  17. BIN  dist/build/HShopenscad-0.1.1.o
  18. BIN  dist/build/HShopenscad-0.1.2.o
  19. BIN  dist/build/Language/HOpenSCAD.hi
  20. BIN  dist/build/Language/HOpenSCAD.o
  21. BIN  dist/build/Language/HOpenSCAD/Export.hi
  22. BIN  dist/build/Language/HOpenSCAD/Export.o
  23. BIN  dist/build/Language/HOpenSCAD/Solid.hi
  24. BIN  dist/build/Language/HOpenSCAD/Solid.o
  25. BIN  dist/build/Language/HOpenSCAD/Types.hi
  26. BIN  dist/build/Language/HOpenSCAD/Types.o
  27. +32 0 dist/build/autogen/Paths_hopenscad.hs
  28. +9 0 dist/build/autogen/cabal_macros.h
  29. BIN  dist/build/libHShopenscad-0.1.1.a
  30. BIN  dist/build/libHShopenscad-0.1.2.a
  31. +2 0  dist/package.conf.inplace
  32. +2 0  dist/setup-config
  33. +38 0 hopenscad.cabal
  34. +0 42 mecha.cabal
11 Language/HOpenSCAD.hs
... ... @@ -0,0 +1,11 @@
  1 +-- | HOpenSCAD is a constructive solid modeling language.
  2 +module Language.HOpenSCAD
  3 + ( module Language.HOpenSCAD.Export
  4 + , module Language.HOpenSCAD.Solid
  5 + , module Language.HOpenSCAD.Types
  6 + ) where
  7 +
  8 +import Language.HOpenSCAD.Export
  9 +import Language.HOpenSCAD.Solid
  10 +import Language.HOpenSCAD.Types
  11 +
BIN  Language/HOpenSCAD/.Types.hs.swp
Binary file not shown
0  Language/Mecha/Examples/CSG.hs → Language/HOpenSCAD/Examples/CSG.hs
File renamed without changes
54 Language/Mecha/Export.hs → Language/HOpenSCAD/Export.hs
... ... @@ -1,59 +1,16 @@
1 1 -- | Export model generation.
2   -module Language.Mecha.Export
3   - ( povray
4   - , openSCAD
  2 +module Language.HOpenSCAD.Export
  3 + (
  4 + openSCAD
5 5 ) where
6 6
7 7 import Text.Printf
8 8
9   -import Language.Mecha.Solid
  9 +import Language.HOpenSCAD.Solid
10 10
11   --- Generates a POV-Ray model.
12   -povray :: Solid -> String
13   -povray a = unlines
14   - [ "// Generated by Mecha (https://github.com/tomahawkins/mecha)"
15   - , ""
16   - , solid a
17   - , ""
18   - ]
19   - where
20   -
21   - solid :: Solid -> String
22   - solid a = case a of
23   - Primitive t (r, g, b, o) a -> printf "%s { %s\n%s%s}\n" a1 a2 (indent $ concatMap transform t) (indent color)
24   - where
25   - color :: String
26   - color = printf "pigment { rgbt <%f, %f, %f, %f> }\n" r g b (1 - o)
27   - a1 :: String
28   - a2 :: String
29   - (a1, a2) = case a of
30   - Sphere d -> ("sphere", printf "<0, 0, 0>, %f" (d / 2))
31   - Cone bd td h -> ("cone", printf "<0, 0, 0>, %f <0, %f, 0>, %f" (bd / 2) h (td / 2))
32   - Box (x1, x2) (y1, y2) (z1, z2) -> ("box", printf "<%f, %f, %f>, <%f, %f, %f>" xmin zmin ymin xmax zmax ymax)
33   - where
34   - xmin = min x1 x2
35   - xmax = max x1 x2
36   - ymin = min y1 y2
37   - ymax = max y1 y2
38   - zmin = min z1 z2
39   - zmax = max z1 z2
40   - Torus d1 d2 -> ("torus", printf "%f, %f" (d1 / 2) (d2 / 2))
41   - Union a b -> printf "merge {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
42   - Intersection a b -> printf "intersection {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
43   - Difference a b -> printf "difference {\n%s%s}\n" (indent $ solid a) (indent $ solid b)
44   -
45   - transform :: Transform -> String
46   - transform a = case a of
47   - Scale (x, y, z) -> printf "scale <%f, %f, %f>\n" x z y
48   - Move (x, y, z) -> printf "translate <%f, %f, %f>\n" x z y
49   - RotateX a -> printf "rotate <%f, 0, 0>\n" (-a * 180 / pi)
50   - RotateY a -> printf "rotate <0, 0, %f>\n" (-a * 180 / pi)
51   - RotateZ a -> printf "rotate <0, %f, 0>\n" (-a * 180 / pi)
52   -
53   --- Generates an OpenSCAD model.
54 11 openSCAD :: Solid -> String
55 12 openSCAD a = unlines
56   - [ "// Generated by Mecha (https://github.com/tomahawkins/mecha)"
  13 + [ "// Generated by HOpenSCAD )"
57 14 , ""
58 15 , solid a
59 16 , ""
@@ -75,6 +32,7 @@ openSCAD a = unlines
75 32 RotateX a : rest -> printf "rotate (%f, [1, 0, 0]) %s" (a * 180 / pi) $ transform rest
76 33 RotateY a : rest -> printf "rotate (%f, [0, 1, 0]) %s" (a * 180 / pi) $ transform rest
77 34 RotateZ a : rest -> printf "rotate (%f, [0, 0, 1]) %s" (a * 180 / pi) $ transform rest
  35 + Reflect (x,y,z) : rest -> printf "mirror ([%f, %f, %f]) %s" x y z $ transform rest
78 36
79 37 primitive :: Primitive -> String
80 38 primitive a = case a of
9 Language/Mecha/Solid.hs → Language/HOpenSCAD/Solid.hs
... ... @@ -1,7 +1,8 @@
1   -module Language.Mecha.Solid
  1 +module Language.HOpenSCAD.Solid
2 2 ( Solid (..)
3 3 , Primitive (..)
4 4 , Transform (..)
  5 + , Reflectable (..)
5 6 , sphere
6 7 , cone
7 8 , box
@@ -13,7 +14,7 @@ module Language.Mecha.Solid
13 14 , torus
14 15 ) where
15 16
16   -import Language.Mecha.Types
  17 +import Language.HOpenSCAD.Types
17 18
18 19 data Solid
19 20 = Primitive [Transform] Color Primitive
@@ -35,6 +36,7 @@ data Transform
35 36 | RotateX Double
36 37 | RotateY Double
37 38 | RotateZ Double
  39 + | Reflect Vector
38 40 deriving Eq
39 41
40 42 transform :: Transform -> Solid -> Solid
@@ -50,6 +52,9 @@ instance Moveable Solid where
50 52 rotateY a = transform $ RotateY a
51 53 rotateZ a = transform $ RotateZ a
52 54
  55 +instance Reflectable Solid where
  56 + reflect = transform . Reflect
  57 +
53 58 instance Scaleable Solid where
54 59 scale a = transform $ Scale a
55 60
14 Language/Mecha/Types.hs → Language/HOpenSCAD/Types.hs
... ... @@ -1,9 +1,10 @@
1   -module Language.Mecha.Types
  1 +module Language.HOpenSCAD.Types
2 2 ( Vector, Vertex, Normal, Color
3 3 , Moveable (..)
4 4 , Scaleable (..)
5 5 , Colorable (..)
6 6 , Setable (..)
  7 + , Reflectable (..)
7 8 , moveX
8 9 , moveY
9 10 , moveZ
@@ -11,6 +12,9 @@ module Language.Mecha.Types
11 12 , scaleX
12 13 , scaleY
13 14 , scaleZ
  15 + , reflectX
  16 + , reflectY
  17 + , reflectZ
14 18 , unions
15 19 ) where
16 20
@@ -25,6 +29,14 @@ class Moveable a where
25 29 rotateY :: Double -> a -> a
26 30 rotateZ :: Double -> a -> a
27 31
  32 +class Reflectable a where
  33 + reflect :: Vector -> a -> a
  34 +
  35 +reflectX, reflectY, reflectZ :: (Moveable a, Reflectable a) => Double -> a -> a
  36 +reflectX k = moveX (2*k) . reflect (1,0,0)
  37 +reflectY k = moveY (2*k) . reflect (0,1,0)
  38 +reflectZ k = moveZ (2*k) . reflect (0,0,1)
  39 +
28 40 moveX :: Moveable a => Double -> a -> a
29 41 moveX a = move (a, 0, 0)
30 42
11 Language/Mecha.hs
... ... @@ -1,11 +0,0 @@
1   --- | Mecha is a constructive solid modeling language.
2   -module Language.Mecha
3   - ( module Language.Mecha.Export
4   - , module Language.Mecha.Solid
5   - , module Language.Mecha.Types
6   - ) where
7   -
8   -import Language.Mecha.Export
9   -import Language.Mecha.Solid
10   -import Language.Mecha.Types
11   -
14 MechaExamples.hs
... ... @@ -1,14 +0,0 @@
1   -module Main (main) where
2   -
3   -import Language.Mecha
4   -import Language.Mecha.Examples.CSG
5   -
6   -main :: IO ()
7   -main = do
8   - writeFile "csg.scad" $ openSCAD $ scaleAll 10 $ csg
9   - putStrLn ""
10   - putStrLn "Writing file: csg.scad"
11   - putStrLn ""
12   - putStrLn "Open with OpenSCAD, then click Design->Compile."
13   - putStrLn ""
14   -
8 README.md
Source Rendered
@@ -2,13 +2,13 @@
2 2
3 3 Mecha is an constructive solid geometry modeling language embedded in [Haskell](http://haskell.org/).
4 4
5   -Mecha compiles models to [POV-Ray](http://povray.org/) and [OpenSCAD](http://openscad.org/).
  5 +Mecha compiles models to [OpenSCAD](http://openscad.org/).
6 6
7   -## Links
  7 +# Release Notes
8 8
9   -- [Mecha Hackage Library](http://hackage.haskell.org/package/mecha)
  9 +0.1.2 01/05/12
10 10
11   -# Release Notes
  11 +-- Forked from [Mecha Hackage Library](http://hackage.haskell.org/package/mecha)
12 12
13 13 0.1.1 06/11/11
14 14
117 attic/Assembly.hs
... ... @@ -1,117 +0,0 @@
1   -module Language.Mecha.Assembly
2   - ( Assembly
3   - , part
4   - , assemble
5   - , Scene
6   - , Camera (..)
7   - , view
8   - , animate
9   - ) where
10   -
11   -import Control.Monad
12   -import qualified Data.ByteString.Char8 as BS
13   -import Data.Digest.CRC32
14   -import Language.Mecha.Solid
15   -import Language.Mecha.Types
16   -import System.Directory
17   -import System.Process
18   -import Text.Printf
19   -
20   --- | An Assembly holds all the parts and sub-assemblies.
21   -data Assembly
22   - = Assembly [Assembly]
23   - | Part Solid
24   - | Label String Assembly
25   - deriving Eq
26   -
27   --- | General assembly.
28   -class Assemble a where assemble :: a -> Assembly
29   -
30   -instance Assemble Assembly where assemble = id
31   -instance Assemble Solid where assemble = Part
32   -instance Assemble a => Assemble [a] where assemble = Assembly . map assemble
33   -
34   --- | A general model transformer.
35   -class SMap a where smap :: (Solid -> Solid) -> a -> a
36   -instance SMap Solid where smap = ($)
37   -instance SMap Assembly where
38   - smap f a = case a of
39   - Assembly a -> Assembly $ map (smap f) a
40   - Part a -> Part $ smap f a
41   - Label n a -> Label n $ smap f a
42   -
43   -instance Colorable Assembly where color c = smap . color c
44   -
45   -instance Moveable Assembly where
46   - move a = smap . move a
47   - rotateX a = smap . rotateX a
48   - rotateY a = smap . rotateY a
49   - rotateZ a = smap . rotateZ a
50   -
51   -instance Scaleable Assembly where scale v = smap . scale v
52   -
53   --- | A Scene is a light position, camera configuration, and an assembly.
54   -type Scene = (Camera, Asm)
55   -
56   --- | Defines a camera configuration.
57   -data Camera
58   - = Orthographic -- ^ Orthographgic projection at the origin with a radius.
59   - | Perspective -- ^ Perspective projection given a camera location and a target.
60   - deriving Eq
61   -
62   --- | Renders 3 orthographic views and 1 perspective view and creates a little html page or the images. Assembly should be within 1 of origin.
63   -view :: FilePath -> Int -> Int -> Asm -> IO ()
64   -view f h w a = do
65   - writeFile (f ++ ".html") $ unlines
66   - [ printf "<table border=\"1\">"
67   - , printf "<tr><td><img src=\"%sTop.png\"/></td><td><img src=\"%sPersp.png\"/></td></tr>\n" f f
68   - , printf "<tr><td><img src=\"%sFront.png\"/></td><td><img src=\"%sRight.png\"/></td></tr>\n" f f
69   - , printf "</table>"
70   - ]
71   - render (f ++ "Top") h w Orthographic $ rotateX (pi/2) a
72   - render (f ++ "Front") h w Orthographic $ a
73   - render (f ++ "Right") h w Orthographic $ rotateZ (-pi/2) a
74   - render (f ++ "Persp") h w Perspective $ moveY 1 $ rotateX (pi/4) $ rotateZ (-pi/6) a
75   -
76   --- | Renders a MPEG movie with POVRay and ffmpeg given a file name (w/o file extension), heigth, width, frames-per-second, and a list of scenes.
77   -animate :: FilePath -> Int -> Int -> Int -> [Scene] -> IO ()
78   -animate file h w fps scenes = do
79   - sequence_ [ printf "[ %d of %d ]\n" i n >> render (printf "%s%05d" file i) h w camera asm | (i, (camera, asm)) <- zip [1 .. n] scenes ]
80   - rm $ file ++ ".mpg"
81   - readProcess "ffmpeg" ["-sameq", "-i", file ++ "%05d.png", "-r", show fps, file ++ ".mpg"] ""
82   - sequence_ [ rm $ printf "%s%05d.png" file i | i <- [1 .. n] ]
83   - where
84   - n = length scenes
85   -
86   --- | Renders a scene.
87   -render :: String -> Int -> Int -> Camera -> Asm -> IO ()
88   -render file h w camera (Asm a) = do
89   - ln image link
90   - a <- doesFileExist image
91   - when (not a) $ do
92   - writeFile (file ++ ".pov") povray'
93   - readProcess "povray" ["-D", "-V", "+H" ++ show h, "+W" ++ show w, "+I" ++ file ++ ".pov", "+O" ++ image] ""
94   - --rm $ file ++ ".pov"
95   - return ()
96   - where
97   - checksum = printf "%08X" $ crc32 $ BS.pack $ show (h, w, povray')
98   - image = checksum ++ ".png"
99   - link = file ++ ".png"
100   - r :: Double
101   - r = fromIntegral w / fromIntegral h
102   - povray' :: String
103   - povray' = unlines
104   - [ "#include \"colors.inc\""
105   - , "background { color White }"
106   - , printf "light_source { <100, 100, -100> color White }"
107   - , case camera of
108   - Perspective -> printf "camera { perspective location <0, 0, 0> right x*%f direction <0, 0, 1> }" r
109   - Orthographic -> printf "camera { orthographic location <0,0,-100> up y*1 right x*%f }" r
110   - ] ++ concatMap povray a
111   -
112   -rm :: FilePath -> IO ()
113   -rm f = system ("rm -f " ++ f) >> return ()
114   -
115   -ln :: FilePath -> FilePath -> IO ()
116   -ln a b = system ("ln -f -s " ++ a ++ " " ++ b) >> return ()
117   -
246 attic/Mesh.hs
... ... @@ -1,246 +0,0 @@
1   -module Language.Mecha.Mesh
2   - ( mesh
3   - ) where
4   -
5   -import Data.Map (Map)
6   -import qualified Data.Map as M
7   -import Data.Maybe
8   -
9   -import Language.Mecha.Solid
10   -import Language.Mecha.Types hiding (rotateX, rotateY, rotateZ)
11   -
12   --- | Creates a triangle mesh from a solid.
13   -mesh :: Double -> Double -> Int -> Solid -> [(Vector, Vector)] -- [(normal, vector), ...]
14   -mesh radius p n solid = polygons
15   - where
16   - num = ceiling $ radius / p
17   - i = [-num .. num]
18   - j = [-num .. num - 1]
19   - vertices :: Map (Int, Int, Int) (Maybe Vertex, Maybe Vertex, Maybe Vertex)
20   - vertices = M.fromList [ ((x, y, z), (f (x + 1, y, z), f (x, y + 1, z), f (x, y, z + 1))) | x <- i, y <- i, z <- i, let f = edge (x,y,z) ]
21   - edge (ax, ay, az) (bx, by, bz) = sdEdge solid n (p * fromIntegral ax, p * fromIntegral ay, p * fromIntegral az) (p * fromIntegral bx, p * fromIntegral by, p * fromIntegral bz)
22   - polygons = concat [ cubePolygons (x, y, z) a | x <- j, y <- j, z <- j, let a = corners solid p (x, y, z), or a, not (and a) ]
23   -
24   - cubePolygons :: (Int, Int, Int) -> [Bool] -> [(Vector, Vector)]
25   - cubePolygons cube config = normals $ map (f . vertexIndex cube) $ polygonConfigurations M.! config
26   - where
27   - f :: ((Int, Int, Int), Axis) -> Vertex
28   - f ((x, y, z), a) = fromJust $ case a of
29   - X -> x'
30   - Y -> y'
31   - Z -> z'
32   - where
33   - (x', y', z') = vertices M.! (x, y, z)
34   -
35   -sdEdge :: Solid -> Int -> Vertex -> Vertex -> Maybe Vertex
36   -sdEdge (Solid f) n a b
37   - | f a && f b || not (f a) && not (f b) = Nothing
38   - | otherwise = Just $ sd n a b
39   - where
40   - sd :: Int -> Vertex -> Vertex -> Vertex
41   - sd n a b | n <= 0 = m
42   - | f a == f m = sd (n - 1) m b
43   - | otherwise = sd (n - 1) a m
44   - where
45   - m = average a b
46   -
47   -average :: Vector -> Vector -> Vector
48   -average (aX, aY, aZ) (bX, bY, bZ) = ((aX+bX)/2, (aY+bY)/2, (aZ+bZ)/2)
49   -
50   -corners :: Solid -> Double -> (Int, Int, Int) -> [Bool]
51   -corners (Solid f) p (x, y, z) = map m
52   - [ (x, y, z)
53   - , (x + 1, y, z)
54   - , (x + 1, y + 1, z)
55   - , (x, y + 1, z)
56   - , (x, y, z + 1)
57   - , (x + 1, y, z + 1)
58   - , (x + 1, y + 1, z + 1)
59   - , (x, y + 1, z + 1)
60   - ]
61   - where
62   - m (x, y, z) = f (p * fromIntegral x, p * fromIntegral y, p * fromIntegral z)
63   -
64   -normals :: [Vector] -> [(Vector, Vector)] -- Normals follow right hand rule for triangles.
65   -normals [] = []
66   -normals (a:b:c:d) = [(normal, a), (normal, b), (normal, c)] ++ normals d
67   - where
68   - (ax, ay, az) = a
69   - (bx, by, bz) = b
70   - (cx, cy, cz) = c
71   - vx = bx - ax
72   - vy = by - ay
73   - vz = bz - az
74   - wx = cx - ax
75   - wy = cy - ay
76   - wz = cz - az
77   - mx = vy * wz - vz * wy
78   - my = vz * wx - vx * wz
79   - mz = vx * wy - vy * wx
80   - mag = sqrt $ mx ** 2 + my ** 2 + mz ** 2
81   - normal = (mx / mag, my / mag, mz / mag)
82   -normals _ = undefined
83   -
84   -patterns :: [([Bool], [Edge])]
85   -patterns =
86   - [ ([x, o, o, o, o, o, o, o], [A, D, E])
87   -
88   - , ([x, x, o, o, o, o, o, o], [B, D, F, F, D, E])
89   - , ([x, o, o, o, o, x, o, o], [A, D, E, I, J, F])
90   - , ([x, o, o, o, o, o, x, o], [A, D, E, J, K, G])
91   -
92   - , ([o, x, x, x, o, o, o, o], [F, G, H, H, D, F, D, A, F])
93   - , ([x, x, o, o, o, o, x, o], [F, B, D, F, D, E, J, K, G])
94   - , ([o, x, o, o, x, o, x, o], [F, B, A, J, K, G, E, L, I])
95   -
96   - , ([x, x, x, x, o, o, o, o], [E, F, G, G, H, E])
97   - , ([o, x, x, x, x, o, o, o], [F, G, H, F, H, D, A, F, D, E, L, I])
98   - , ([x, o, x, o, o, x, o, x], [A, D, E, B, G, C, F, I, J, K, L, H])
99   - , ([x, o, x, x, o, o, o, x], [B, G, A, A, G, K, A, K, E, E, K, L])
100   - , ([o, x, x, x, o, o, o, x], [G, K, L, G, L, A, A, L, D])
101   - , ([x, o, x, o, x, o, x, o], [B, J, C, K, C, J, D, I, A, D, L, I])
102   - , ([x, o, x, x, o, o, x, o], [B, J, A, A, J, H, H, J, K, A, H, E])
103   - ]
104   - where
105   - x = True
106   - o = False
107   -
108   -mirrorX [a,b,c,d,e,f,g,h] = [b,a,d,c,f,e,h,g]
109   -mirrorX _ = undefined
110   -mirrorY [a,b,c,d,e,f,g,h] = [d,c,b,a,h,g,f,e]
111   -mirrorY _ = undefined
112   -rotateX [a,b,c,d,e,f,g,h] = [e,f,b,a,h,g,c,d]
113   -rotateX _ = undefined
114   -rotateY [a,b,c,d,e,f,g,h] = [b,f,g,c,a,e,h,d]
115   -rotateY _ = undefined
116   -rotateZ [a,b,c,d,e,f,g,h] = [d,a,b,c,h,e,f,g]
117   -rotateZ _ = undefined
118   -rotateXZ = rotateZ . rotateX
119   -
120   -data Op = Invert | RotateXZ | RotateX | RotateY | MirrorX | MirrorY deriving Show
121   -data Axis = X | Y | Z
122   -
123   -polygonConfigurations :: Map [Bool] [Edge]
124   -polygonConfigurations = M.fromList [ (a, f a) | a <- allConfigs ]
125   - where
126   - allConfigs = filter (\ a -> or a && not (and a)) $ sequence (replicate 8 a) where a = [True, False]
127   - f :: [Bool] -> [Edge]
128   - f config = foldr unOp edges ops
129   - where
130   - (_, ops, edges) = findPattern config
131   -
132   -findPattern :: [Bool] -> ([Bool], [Op], [Edge])
133   -findPattern a = head [ (config, ops, fromJust $ lookup config patterns) | (config, ops) <- orient [Invert, RotateXZ, RotateXZ, RotateX, RotateY, MirrorX, MirrorY] [] a, elem config $ fst $ unzip $ patterns ]
134   - where
135   - orient :: [Op] -> [Op] -> [Bool] -> [([Bool], [Op])]
136   - orient [] ops a = [(a, reverse ops)]
137   - orient (f:fs) ops a = orient fs ops a ++ orient fs (f:ops) (op f a)
138   - op f = case f of
139   - Invert -> map not
140   - RotateXZ -> rotateXZ
141   - RotateX -> rotateX
142   - RotateY -> rotateY
143   - MirrorX -> mirrorX
144   - MirrorY -> mirrorY
145   -
146   -
147   -data Edge = A | B | C | D | E | F | G | H | I | J | K | L deriving Show
148   -
149   -unOp :: Op -> [Edge] -> [Edge]
150   -unOp op edges = case op of
151   - Invert -> unOpInvert edges
152   - RotateXZ -> map unOpRotateXZ edges
153   - RotateX -> map unOpRotateX edges
154   - RotateY -> map unOpRotateY edges
155   - MirrorX -> unOpInvert $ map unOpMirrorX edges
156   - MirrorY -> unOpInvert $ map unOpMirrorY edges
157   -
158   -unOpInvert :: [Edge] -> [Edge]
159   -unOpInvert [] = []
160   -unOpInvert (a:b:c:d) = a : c : b : unOpInvert d
161   -unOpInvert _ = undefined
162   -
163   -unOpRotateXZ :: Edge -> Edge
164   -unOpRotateXZ a = case a of
165   - D -> A
166   - H -> B
167   - L -> C
168   - E -> D
169   - A -> E
170   - C -> F
171   - K -> G
172   - I -> H
173   - B -> I
174   - G -> J
175   - J -> K
176   - F -> L
177   -
178   -unOpRotateX :: Edge -> Edge
179   -unOpRotateX a = case a of
180   - C -> A
181   - G -> B
182   - K -> C
183   - H -> D
184   - D -> E
185   - B -> F
186   - J -> G
187   - L -> H
188   - A -> I
189   - F -> J
190   - I -> K
191   - E -> L
192   -
193   -unOpRotateY :: Edge -> Edge
194   -unOpRotateY a = case a of
195   - E -> A
196   - D -> B
197   - H -> C
198   - L -> D
199   - I -> E
200   - A -> F
201   - C -> G
202   - K -> H
203   - F -> I
204   - B -> J
205   - G -> K
206   - J -> L
207   -
208   -unOpMirrorX :: Edge -> Edge
209   -unOpMirrorX a = case a of
210   - E -> F
211   - F -> E
212   - L -> J
213   - J -> L
214   - H -> G
215   - G -> H
216   - D -> B
217   - B -> D
218   - a -> a
219   -
220   -unOpMirrorY :: Edge -> Edge
221   -unOpMirrorY a = case a of
222   - A -> C
223   - C -> A
224   - F -> G
225   - G -> F
226   - E -> H
227   - H -> E
228   - I -> K
229   - K -> I
230   - a -> a
231   -
232   -vertexIndex :: (Int, Int, Int) -> Edge -> ((Int, Int, Int), Axis)
233   -vertexIndex (x, y, z) a = case a of
234   - A -> ((x, y, z), X)
235   - B -> ((x + 1, y, z), Y)
236   - C -> ((x, y + 1, z), X)
237   - D -> ((x, y, z), Y)
238   - E -> ((x, y, z), Z)
239   - F -> ((x + 1, y, z), Z)
240   - G -> ((x + 1, y + 1, z), Z)
241   - H -> ((x, y + 1, z), Z)
242   - I -> ((x, y, z + 1), X)
243   - J -> ((x + 1, y, z + 1), Y)
244   - K -> ((x, y + 1, z + 1), X)
245   - L -> ((x, y, z + 1), Y)
246   -
218 attic/Octree.hs
... ... @@ -1,218 +0,0 @@
1   -module Language.Mecha.Octree
2   - ( Octree (..)
3   - , mesh
4   - ) where
5   -
6   -import Control.Monad
7   -import qualified Data.IntMap as IM
8   -import qualified Data.Map as M
9   -import qualified Graphics.Rendering.OpenGL as GL
10   -
11   -import Language.Mecha.OpenGL
12   -import Language.Mecha.Types
13   -
14   -data Octree
15   - = Octree { center :: Vertex, radius :: Double, u1, u2, u3, u4, l1, l2, l3, l4 :: Octree }
16   - | Surface { point :: Vertex, normal :: Vertex, shade :: Color }
17   - | Inside
18   - | Outside deriving (Show, Eq)
19   -
20   -instance Setable Octree where
21   - union (Octree c r a0 a1 a2 a3 a4 a5 a6 a7) (Octree _ _ b0 b1 b2 b3 b4 b5 b6 b7) = if allInside' then Inside else x
22   - where
23   - x0 = union a0 b0
24   - x1 = union a1 b1
25   - x2 = union a2 b2
26   - x3 = union a3 b3
27   - x4 = union a4 b4
28   - x5 = union a5 b5
29   - x6 = union a6 b6
30   - x7 = union a7 b7
31   - x = Octree c r x0 x1 x2 x3 x4 x5 x6 x7
32   - allInside' = allInside [x0, x1, x2, x3, x4, x5, x6, x7]
33   - union Inside _ = Inside
34   - union _ Inside = Inside
35   - union Outside a = a
36   - union a Outside = a
37   - union a _ = a
38   -
39   - intersection (Octree c r a0 a1 a2 a3 a4 a5 a6 a7) (Octree _ _ b0 b1 b2 b3 b4 b5 b6 b7) = if allOutside' then Outside else x
40   - where
41   - x0 = intersection a0 b0
42   - x1 = intersection a1 b1
43   - x2 = intersection a2 b2
44   - x3 = intersection a3 b3
45   - x4 = intersection a4 b4
46   - x5 = intersection a5 b5
47   - x6 = intersection a6 b6
48   - x7 = intersection a7 b7
49   - x = Octree c r x0 x1 x2 x3 x4 x5 x6 x7
50   - allOutside' = allOutside [x0, x1, x2, x3, x4, x5, x6, x7]
51   - intersection Inside a = a
52   - intersection a Inside = a
53   - intersection Outside _ = Outside
54   - intersection _ Outside = Outside
55   - intersection a _ = a
56   -
57   - difference (Octree c r a0 a1 a2 a3 a4 a5 a6 a7) (Octree _ _ b0 b1 b2 b3 b4 b5 b6 b7) = if allOutside' then Outside else x
58   - where
59   - x0 = difference a0 b0
60   - x1 = difference a1 b1
61   - x2 = difference a2 b2
62   - x3 = difference a3 b3
63   - x4 = difference a4 b4
64   - x5 = difference a5 b5
65   - x6 = difference a6 b6
66   - x7 = difference a7 b7
67   - x = Octree c r x0 x1 x2 x3 x4 x5 x6 x7
68   - allOutside' = allOutside [x0, x1, x2, x3, x4, x5, x6, x7]
69   - difference _ Inside = Outside
70   - difference a Outside = a
71   - difference Outside _ = Outside
72   - difference _ (Octree c r b0 b1 b2 b3 b4 b5 b6 b7) = Octree c r (d b0) (d b1) (d b2) (d b3) (d b4) (d b5) (d b6) (d b7)
73   - where
74   - d = difference Inside
75   - difference _ (Surface p (x, y, z) c) = Surface p (-x, -y, -z) c
76   -
77   -type Path = [Octant]
78   -type Octant = (Bool, Bool, Bool)
79   -data Axis = X | Y | Z deriving Eq
80   -type Direction = (Axis, Bool)
81   -type Context = [(Octree, Octant)]
82   -
83   -neighbor :: Context -> Direction -> (Context, Octree)
84   -neighbor context (axis, sign) = neighbor context []
85   - where
86   - neighbor :: Context -> Path -> (Context, Octree)
87   - neighbor [] _ = ([], Outside)
88   - neighbor ((octree, (x, y, z)) : context) path = case axis of
89   - X | xor sign x -> subOctree context xPath octree
90   - | otherwise -> neighbor context xPath
91   - Y | xor sign y -> subOctree context yPath octree
92   - | otherwise -> neighbor context yPath
93   - Z | xor sign z -> subOctree context zPath octree
94   - | otherwise -> neighbor context zPath
95   - where
96   - xPath = (not x, y, z) : path
97   - yPath = (x, not y, z) : path
98   - zPath = (x, y, not z) : path
99   -
100   -octant :: Octant -> Octree -> Octree
101   -octant (x, y, z) = if y then a else b
102   - where
103   - (uA, uB, lA, lB) = if x then (u1, u4, l1, l4) else (u2, u3, l2, l3)
104   - (a, b) = if z then (uA, uB) else (lA, lB)
105   -
106   -subOctree :: Context -> Path -> Octree -> (Context, Octree)
107   -subOctree context [] octree = (context, octree)
108   -subOctree context (a:b) octree = case octree of
109   - Octree _ _ _ _ _ _ _ _ _ _ -> subOctree ((octree, a) : context) b (octant a octree)
110   - _ -> (context, octree)
111   -
112   -xor :: Bool -> Bool -> Bool
113   -xor True False = True
114   -xor False True = True
115   -xor _ _ = False
116   -
117   -allInside :: [Octree] -> Bool
118   -allInside a = all (== Inside) a
119   -
120   -allOutside :: [Octree] -> Bool
121   -allOutside a = all (== Outside) a
122   -
123   -allSurface :: [Octree] -> Bool
124   -allSurface = all isSurface
125   -
126   -isSurface :: Octree -> Bool
127   -isSurface (Surface _ _ _) = True
128   -isSurface _ = False
129   -
130   -mesh :: Octree -> IO (IO ())
131   -mesh octree = do
132   - return $ do
133   - GL.renderPrimitive GL.Quads $ render True quads
134   - GL.lighting GL.$= GL.Disabled
135   - GL.depthMask GL.$= GL.Disabled
136   - --GL.lineWidth GL.$= 2
137   - color3 0 0 0
138   - GL.renderPrimitive GL.Lines $ render False lines
139   - GL.depthMask GL.$= GL.Enabled
140   - GL.lighting GL.$= GL.Enabled
141   - where
142   - mesh = meshVertices [] octree
143   - quads :: [Int]
144   - quads = concat [ [id a, id b, id c, id d] | (_, (_, _, a, _)) <- mesh, (a, b, c, d) <- a ]
145   - lines = concat [ [id a, id b, id b, id c, id c, id d, id d, id a] | (_, (_, _, a, _)) <- mesh, (a@(x, y, z), b, c, d) <- a, x >= 0, y >= 0, z >= 0 ]
146   - colors = IM.fromList [ (ids M.! a, color) | (a, (_, _, _, color)) <- mesh ]
147   - normals = IM.fromList [ (ids M.! a, normal) | (a, (normal, _, _, _)) <- mesh ]
148   - vertices1 = fst $ unzip mesh
149   - ids = M.fromList $ zip vertices1 [0..]
150   - id a = ids M.! a
151   - vertices = IM.fromList $ zip [0..] vertices1
152   - render poly a = sequence_ $ map glCmd $ glCmdOpt $ concat $ map (glCmds poly) a
153   -
154   - glCmds :: Bool -> Int -> [GlCmd]
155   - glCmds poly i = (if poly then [C c1 c2 c3, N n1 n2 n3] else []) ++ [V v1 v2 v3]
156   - where
157   - (c1, c2, c3) = colors IM.! i
158   - (n1, n2, n3) = normals IM.! i
159   - (v1, v2, v3) = vertices IM.! i
160   -
161   -glCmd :: GlCmd -> IO ()
162   -glCmd a = case a of
163   - C a b c -> color3 a b c
164   - N a b c -> normal3 a b c
165   - V a b c -> vertex3 a b c
166   -
167   -glCmdOpt :: [GlCmd] -> [GlCmd]
168   -glCmdOpt [] = []
169   -glCmdOpt (a:b) = a : f a b
170   - where
171   - f _ [] = []
172   - f lastColor (a:b) = case a of
173   - C _ _ _ | a == lastColor -> f lastColor b
174   - | otherwise -> a : f a b
175   - _ -> a : f lastColor b
176   -
177   -data GlCmd
178   - = C Double Double Double
179   - | N Double Double Double
180   - | V Double Double Double
181   - deriving Eq
182   -
183   -meshVertices :: Context -> Octree -> [(Vertex, (Vertex, [Vertex], [(Vertex, Vertex, Vertex, Vertex)], Color))]
184   -meshVertices context octree = case octree of
185   - Inside -> []
186   - Outside -> []
187   - Surface p normal color -> [(p, (normal, a ++ b ++ c, m ++ n ++ o, color))]
188   - where
189   - a = if isSurface xp then [point xp] else []
190   - b = if isSurface yp then [point yp] else []
191   - c = if isSurface zp then [point zp] else []
192   - m = f xp xpyp yp
193   - n = f yp ypzp zp
194   - o = f xp xpzp zp
195   - (xpC, xp) = neighbor context (X, True)
196   - (ypC, yp) = neighbor context (Y, True)
197   - (_, zp) = neighbor context (Z, True)
198   - (_, xpyp) = neighbor xpC (Y, True)
199   - (_, ypzp) = neighbor ypC (Z, True)
200   - (_, xpzp) = neighbor xpC (Z, True)
201   - f :: Octree -> Octree -> Octree -> [(Vertex, Vertex, Vertex, Vertex)]
202   - f a b c = case (isSurface a, isSurface b, isSurface c) of
203   - (True, True, True) -> [(p, point a, point b, point c)]
204   - (True, False, True) -> [(p, point a, point a, point c)] -- XXX Redundent.
205   - (True, True, False) -> [(p, point a, point a, point b)] -- XXX Redundent.
206   - (False, True, True) -> [(p, point b, point b, point c)] -- XXX Redundent.
207   - _ -> []
208   - octree -> concat
209   - [ meshVertices ((octree, (True, True, True )) : context) $ u1 octree
210   - , meshVertices ((octree, (False, True, True )) : context) $ u2 octree
211   - , meshVertices ((octree, (False, False, True )) : context) $ u3 octree
212   - , meshVertices ((octree, (True, False, True )) : context) $ u4 octree
213   - , meshVertices ((octree, (True, True, False)) : context) $ l1 octree
214   - , meshVertices ((octree, (False, True, False)) : context) $ l2 octree
215   - , meshVertices ((octree, (False, False, False)) : context) $ l3 octree
216   - , meshVertices ((octree, (True, False, False)) : context) $ l4 octree
217   - ]
218   -
31 attic/OpenGL.hs
... ... @@ -1,31 +0,0 @@
1   -module Language.Mecha.OpenGL
2   - ( vertex3
3   - , normal3
4   - , color3
5   - , scale3
6   - , translate3
7   - , rotate3
8   - ) where
9   -
10   -import Graphics.Rendering.OpenGL
11   -
12   ---vertex3 :: Real a => a -> a -> a -> IO ()
13   -vertex3 x y z = vertex $ Vertex3 (toFloat x) (toFloat y) (toFloat z)
14   -
15   ---normal3 :: Real a => a -> a -> a -> IO ()
16   -normal3 x y z = normal $ Normal3 (toFloat x) (toFloat y) (toFloat z)
17   -
18   ---color3 :: Real a => a -> a -> a -> IO ()
19   -color3 r g b = color $ Color3 (toFloat r) (toFloat g) (toFloat b)
20   -
21   ---scale3 :: Real a => a -> a -> a -> IO ()
22   -scale3 x y z = scale (toFloat x) (toFloat y) (toFloat z)
23   -
24   ---translate3 :: Real a => a -> a -> a -> IO ()
25   -translate3 x y z = translate $ Vector3 (toFloat x) (toFloat y) (toFloat z)
26   -
27   ---rotate3 :: (Real a, Floating a) => a -> a -> a -> a -> IO ()
28   -rotate3 angle x y z = rotate (toFloat $ angle * 180 / pi) $ Vector3 (toFloat x) (toFloat y) (toFloat z)
29   -
30   -toFloat :: (Real a, Floating a) => a -> GLfloat
31   -toFloat = realToFrac
20 attic/Primitives.hs
... ... @@ -1,20 +0,0 @@
1   -module Language.Mecha.Primitives
2   - ( sphere
3   - , cube
4   - , cylinder
5   - ) where
6   -
7   -import Language.Mecha.Solid
8   -
9   --- | A sphere with radius 1 centered at origin.
10   -sphere :: Solid
11   -sphere = Solid $ \ (x, y, z) -> sqrt (x ** 2 + y ** 2 + z ** 2) <= 1
12   -
13   --- | A sphere with edge length 2 centered at origin.
14   -cube :: Solid
15   -cube = Solid $ \ (x, y, z) -> all (\ a -> a <= 1 && a >= (-1)) [x, y, z]
16   -
17   --- | A cylinder with radius 1 and height 2 centered at origin.
18   -cylinder :: Solid
19   -cylinder = Solid $ \ (x, y, z) -> z <= 1 && z >= (-1) && sqrt (x ** 2 + y ** 2) <= 1
20   -
247 attic/Viewer.hs
... ... @@ -1,247 +0,0 @@
1   -module Language.Mecha.Viewer
2   - ( viewer
3   - ) where
4   -
5   -import Control.Monad
6   -import Graphics.Rendering.OpenGL
7   -import Graphics.UI.SDL hiding (init, Color)
8   -import qualified Graphics.UI.SDL as SDL
9   -
10   -import Language.Mecha.OpenGL
11   -
12   -data State = State
13   - { leftButton
14   - , middleButton
15   - , rightButton :: Bool
16   - , theta
17   - , phi
18   - , scale'
19   - , theta'
20   - , phi' :: Float
21   - , x'
22   - , y' :: Int
23   - , i
24   - , j
25   - , i'
26   - , j' :: Float
27   - , running :: Bool
28   - } deriving Show
29   -
30   -initState = State
31   - { leftButton = False
32   - , middleButton = False
33   - , rightButton = False
34   - , theta = 45 * pi / 180
35   - , phi = 30 * pi / 180
36   - , scale' = 0.4
37   - , theta' = 0
38   - , phi' = 0
39   - , x' = 0
40   - , y' = 0
41   - , i = 0
42   - , j = 0
43   - , i' = 0
44   - , j' = 0
45   - , running = True
46   - }
47   -
48   -type Model = IO ()
49   -
50   -viewer :: Model -> IO ()
51   -viewer model = do
52   - SDL.init [InitVideo]
53   - setCaption "ModelView" "ModelView"
54   - glSetAttribute glRedSize 8
55   - glSetAttribute glGreenSize 8
56   - glSetAttribute glBlueSize 8
57   - glSetAttribute glAlphaSize 8
58   - glSetAttribute glDepthSize 24
59   - glSetAttribute glDoubleBuffer 1
60   - setView 600 400
61   - cullFace $= Nothing
62   - shadeModel $= Smooth
63   - normalize $= Enabled
64   -
65   - position (Light 0) $= Vertex4 1 1 1 0
66   - ambient (Light 0) $= Color4 0.3 0.3 0.3 1
67   - diffuse (Light 0) $= Color4 1 1 1 1
68   - --specular (Light 0) $= Color4 0 0 0 1
69   - specular (Light 0) $= Color4 1 1 1 1
70   - lightModelAmbient $= Color4 0.2 0.2 0.2 1
71   - lighting $= Enabled
72   - light (Light 0) $= Enabled
73   - colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)
74   - materialSpecular FrontAndBack $= Color4 1 1 1 1
75   - materialEmission FrontAndBack $= Color4 0 0 0 1
76   - materialShininess FrontAndBack $= 30
77   -
78   - clearColor $= Color4 1 1 1 0
79   - clearDepth $= 1
80   - depthFunc $= Just Less
81   - depthMask $= Enabled
82   - loop model initState
83   - quit
84   -
85   -setView :: Int -> Int -> IO ()
86   -setView w h = do
87   - setVideoMode w h 16 [OpenGL, Resizable] >> return ()
88   - matrixMode $= Projection
89   - loadIdentity
90   - let r = (fromIntegral w / fromIntegral h)
91   - frustum (-r * 0.1) (r * 0.1) (-0.1) 0.1 0.1 100000
92   - matrixMode $= Modelview 0
93   - viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h))
94   -
95   -redraw :: Model -> State -> IO ()
96   -redraw model state = do
97   - clear [ColorBuffer, DepthBuffer]
98   - loadIdentity
99   - stateView state
100   - lighting $= Disabled
101   - orign
102   - lighting $= Enabled
103   - model
104   - flush
105   - glSwapBuffers
106   -
107   -stateView :: State -> IO ()
108   -stateView state = do
109   - translate3 0 0 (-1)
110   - rotate3 (phi state) 1 0 0
111   - rotate3 (theta state) 0 1 0
112   - rotate3 (-pi / 2) 1 0 0
113   - rotate3 (-pi / 2) 0 0 1
114   - scale3 (scale' state) (scale' state) (scale' state)
115   -
116   -
117   -
118   -
119   -
120   -
121   -
122   -
123   -loop :: Model -> State -> IO ()
124   -loop model state = do
125   - event <- pollEvent
126   - state <- handler event model state
127   - when (event /= Quit) $ loop model state
128   -
129   -handler :: Event -> Model -> State -> IO State
130   -handler event model state = case event of
131   - NoEvent -> return state
132   - VideoExpose -> redraw model state >> return state
133   - VideoResize x y -> setView x y >> return state
134   - event -> case nextState event state of
135   - Nothing -> return state
136   - Just state -> redraw model state >> return state
137   -
138   -nextState :: Event -> State -> Maybe State
139   -nextState event state = case event of
140   - MouseMotion x y _ _ | middleButton state -> Just state
141   - { phi = phi' state + 0.01 * fromIntegral (fromIntegral y - y' state)
142   - , theta = theta' state + 0.01 * fromIntegral (fromIntegral x - x' state)
143   - }
144   - MouseMotion x _ _ _ | leftButton state -> Just state { i = i' state + 0.01 * fromIntegral (fromIntegral x - x' state) }
145   - MouseMotion x _ _ _ | rightButton state -> Just state { j = j' state + 0.01 * fromIntegral (fromIntegral x - x' state) }
146   -
147   - MouseButtonDown x y ButtonMiddle -> Just state
148   - { leftButton = False
149   - , middleButton = True
150   - , rightButton = False
151   - , x' = fromIntegral x
152   - , y' = fromIntegral y
153   - , phi' = phi state
154   - , theta' = theta state
155   - }
156   -
157   - MouseButtonDown x y ButtonLeft -> Just state
158   - { leftButton = True
159   - , middleButton = False
160   - , rightButton = False
161   - , x' = fromIntegral x
162   - , y' = fromIntegral y
163   - , i' = i state
164   - , j' = j state
165   - }
166   -
167   - MouseButtonDown x y ButtonRight -> Just state
168   - { leftButton = False
169   - , middleButton = False
170   - , rightButton = True
171   - , x' = fromIntegral x
172   - , y' = fromIntegral y
173   - , i' = i state
174   - , j' = j state
175   - }
176   -
177   - MouseButtonUp _ _ ButtonLeft -> Just state { leftButton = False }
178   - MouseButtonUp _ _ ButtonMiddle -> Just state { middleButton = False }
179   - MouseButtonUp _ _ ButtonRight -> Just state { rightButton = False }
180   - MouseButtonDown _ _ ButtonWheelUp -> Just state { scale' = scale' state * 1.2 }
181   - MouseButtonDown _ _ ButtonWheelDown -> Just state { scale' = scale' state / 1.2 }
182   - _ -> Nothing
183   -
184   -darkGray = color3 0.4 0.4 0.4
185   ---lightGray = color3 0.7 0.7 0.7
186   -
187   -orign :: IO ()
188   -orign = do
189   - lineWidth $= 1
190   - renderPrimitive Lines $ do
191   - color3 0.7 0 0
192   - vertex3 0 0 0
193   - vertex3 inf 0 0
194   - color3 0 0.7 0
195   - vertex3 0 0 0
196   - vertex3 0 inf 0
197   - color3 0 0 0.7
198   - vertex3 0 0 0
199   - vertex3 0 0 inf
200   - darkGray
201   - vertex3 0 0 0
202   - vertex3 (-inf) 0 0
203   - vertex3 0 0 0
204   - vertex3 0 (-inf) 0
205   - vertex3 0 0 0
206   - vertex3 0 0 (-inf)
207   - where
208   - inf = 1e6
209   -
210   -{-
211   -plane :: Float -> Int -> Int -> IO ()
212   -plane delta linesPerMajor totalMajors = do
213   - lineWidth $= 1
214   - renderPrimitive Lines $ line 1 (linesPerMajor - 1) delta
215   - where
216   - y = delta * fromIntegral (linesPerMajor * totalMajors)
217   - line :: Int -> Int -> Float -> IO ()
218   - line majorCount _ _ | majorCount > totalMajors = return ()
219   - line majorCount minorCount x | minorCount == 0 = do
220   - darkGray
221   - line' x
222   - line (majorCount + 1) (linesPerMajor - 1) (x + delta)
223   - line majorCount minorCount x = do
224   - lightGray
225   - line' x
226   - line majorCount (minorCount - 1) (x + delta)
227   - line' x = do
228   - vertex3 x y 0
229   - vertex3 x (-y) 0
230   - vertex3 (-x) y 0
231   - vertex3 (-x) (-y) 0
232   - vertex3 y x 0
233   - vertex3 (-y) x 0
234   - vertex3 y (-x) 0
235   - vertex3 (-y) (-x) 0
236   --}
237   -{-
238   -posZ0 :: Int -> Int -> IO (Maybe (Float,Float))
239   -posZ0 x y = do
240   - ((x1,y1,z1),(x2,y2,z2)) <- unProject x y
241   - if z1 > 0 && z2 > 0 || z1 < 0 && z2 < 0 then return Nothing else do
242   - let r = abs z1 / abs (z2 - z1)
243   - x' = r * (x2 - x1) + x1
244   - y' = r * (y2 - y1) + y1
245   - return $ Just (x',y')
246   --}
247   -
62 attic/Visual.hs
... ... @@ -1,62 +0,0 @@
1   -module Language.Mecha.Visual
2   - ( visual
3   - ) where
4   -
5   -import Graphics.UI.GLUT
6   -
7   -import Language.Mecha.Assembly
8   -
9   -visual :: Asm -> IO ()
10   -visual _ = do
11   - initialize "Mecha" []
12   - initialWindowSize $= Size 800 600
13   - initialDisplayMode $= [RGBAMode, WithDepthBuffer, DoubleBuffered]
14   - actionOnWindowClose $= MainLoopReturns
15   - createWindow "Mecha Visual"
16   - setView 800 600
17   - displayCallback $= redraw
18   - reshapeCallback $= (Just $ \ (Size w h) -> setView (fromIntegral w) (fromIntegral h))
19   - keyboardMouseCallback $= (Just $ \ key keyState mods pos -> do
20   - print key
21   - print keyState
22   - print mods
23   - print pos)
24   -
25   - position (Light 0) $= Vertex4 1 1 0 1
26   -
27   - ambient (Light 0) $= Color4 0 0 0 1
28   - diffuse (Light 0) $= Color4 1 1 1 1
29   - specular (Light 0) $= Color4 1 1 1 1
30   -
31   - lightModelAmbient $= Color4 0.2 0.2 0.2 1
32   - lighting $= Enabled
33   - light (Light 0) $= Enabled
34   - colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)
35   - materialSpecular FrontAndBack $= Color4 1 1 1 1
36   - materialEmission FrontAndBack $= Color4 0 0 0 1
37   - normalize $= Enabled
38   - clearColor $= Color4 0.4 0.4 0.4 1
39   - clearDepth $= 1
40   - depthFunc $= Just Less
41   - depthMask $= Enabled
42   - cullFace $= Nothing
43   - shadeModel $= Smooth
44   - mainLoop
45   -
46   -setView :: Int -> Int -> IO ()
47   -setView w h = do
48   - matrixMode $= Projection
49   - loadIdentity
50   - let r = (fromIntegral w / fromIntegral h)
51   - frustum (-r * 0.1) (r * 0.1) (-0.1) 0.1 0.1 100000
52   - matrixMode $= Modelview 0
53   - viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h))
54   -
55   -redraw :: IO ()
56   -redraw = do
57   - clear [ColorBuffer, DepthBuffer]
58   - loadIdentity
59   - -- XXX
60   - flush
61   - swapBuffers
62   -
BIN  dist/build/HShopenscad-0.1.1.o
Binary file not shown
BIN  dist/build/HShopenscad-0.1.2.o
Binary file not shown
BIN  dist/build/Language/HOpenSCAD.hi
Binary file not shown
BIN  dist/build/Language/HOpenSCAD.o
Binary file not shown
BIN  dist/build/Language/HOpenSCAD/Export.hi
Binary file not shown
BIN  dist/build/Language/HOpenSCAD/Export.o
Binary file not shown
BIN  dist/build/Language/HOpenSCAD/Solid.hi
Binary file not shown
BIN  dist/build/Language/HOpenSCAD/Solid.o
Binary file not shown
BIN  dist/build/Language/HOpenSCAD/Types.hi
Binary file not shown
BIN  dist/build/Language/HOpenSCAD/Types.o
Binary file not shown
32 dist/build/autogen/Paths_hopenscad.hs
... ... @@ -0,0 +1,32 @@
  1 +module Paths_hopenscad (
  2 + version,
  3 + getBinDir, getLibDir, getDataDir, getLibexecDir,
  4 + getDataFileName
  5 + ) where
  6 +
  7 +import qualified Control.Exception as Exception
  8 +import Data.Version (Version(..))
  9 +import System.Environment (getEnv)
  10 +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
  11 +catchIO = Exception.catch
  12 +
  13 +
  14 +version :: Version
  15 +version = Version {versionBranch = [0,1,2], versionTags = []}
  16 +bindir, libdir, datadir, libexecdir :: FilePath
  17 +
  18 +bindir = "/home/paolino/.cabal/bin"
  19 +libdir = "/home/paolino/.cabal/lib/hopenscad-0.1.2/ghc-7.4.1"
  20 +datadir = "/home/paolino/.cabal/share/hopenscad-0.1.2"
  21 +libexecdir = "/home/paolino/.cabal/libexec"
  22 +
  23 +getBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath
  24 +getBinDir = catchIO (getEnv "hopenscad_bindir") (\_ -> return bindir)
  25 +getLibDir = catchIO (getEnv "hopenscad_libdir") (\_ -> return libdir)
  26 +getDataDir = catchIO (getEnv "hopenscad_datadir") (\_ -> return datadir)
  27 +getLibexecDir = catchIO (getEnv "hopenscad_libexecdir") (\_ -> return libexecdir)
  28 +
  29 +getDataFileName :: FilePath -> IO FilePath