-
-
Notifications
You must be signed in to change notification settings - Fork 142
/
Definitions.hs
190 lines (157 loc) · 5.37 KB
/
Definitions.hs
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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Released under the GNU GPL, see LICENSE
module Graphics.Implicit.Definitions where
-- a few imports for great evil :(
-- we want global IO refs.
import Data.IORef (IORef, newIORef, readIORef)
import System.IO.Unsafe (unsafePerformIO)
import Data.VectorSpace
import Control.Applicative
-- Let's make things a bit nicer.
-- Following math notation ℝ, ℝ², ℝ³...
type ℝ = Float
type ℝ2 = (ℝ,ℝ)
type ℝ3 = (ℝ,ℝ,ℝ)
type ℕ = Int
-- TODO: Find a better place for this
(⋅) :: InnerSpace a => a -> a -> Scalar a
(⋅) = (<.>)
-- TODO: Find a better way to do this?
class ComponentWiseMultable a where
(⋯*) :: a -> a -> a
(⋯/) :: a -> a -> a
instance ComponentWiseMultable ℝ2 where
(x,y) ⋯* (x',y') = (x*x', y*y')
(x,y) ⋯/ (x',y') = (x/x', y/y')
instance ComponentWiseMultable ℝ3 where
(x,y,z) ⋯* (x',y',z') = (x*x', y*y', z*z')
(x,y,z) ⋯/ (x',y',z') = (x/x', y/y', z/z')
-- nxn matrices
-- eg. M2 ℝ = M₂(ℝ)
type M2 a = ((a,a),(a,a))
type M3 a = ((a,a,a),(a,a,a),(a,a,a))
-- | A chain of line segments, as in SVG
-- eg. [(0,0), (0.5,1), (1,0)] ---> /\
type Polyline = [ℝ2]
-- | A triangle (a,b,c) = a trinagle with vertices a, b and c
type Triangle = (ℝ3, ℝ3, ℝ3)
-- | A triangle ((v1,n1),(v2,n2),(v3,n3)) has vertices v1, v2, v3
-- with corresponding normals n1, n2, and n3
type NormedTriangle = ((ℝ3, ℝ3), (ℝ3, ℝ3), (ℝ3, ℝ3))
-- | A triangle mesh is a bunch of triangles :)
type TriangleMesh = [Triangle]
-- | A normed triangle mesh is a bunch of normed trianlges!!
type NormedTriangleMesh = [NormedTriangle]
-- $ In Implicit CAD, we consider objects as functions
-- of `outwardness'. The boundary is 0, negative is the
-- interior and positive the exterior. The magnitude is
-- how far out or in.
-- For more details, refer to http://christopherolah.wordpress.com/2011/11/06/manipulation-of-implicit-functions-with-an-eye-on-cad/
-- | A 2D object
type Obj2 = (ℝ2 -> ℝ)
-- | A 3D object
type Obj3 = (ℝ3 -> ℝ)
-- | A 2D box
type Box2 = (ℝ2, ℝ2)
-- | A 3D box
type Box3 = (ℝ3, ℝ3)
-- | Boxed 2D object
type Boxed2 a = (a, Box2)
-- | Boxed 3D object
type Boxed3 a = (a, Box3)
type BoxedObj2 = Boxed2 Obj2
type BoxedObj3 = Boxed3 Obj3
-- | A symbolic 2D object format.
-- We want to have a symbolic object so that we can
-- accelerate rendering & give ideal meshes for simple
-- cases.
data SymbolicObj2 =
-- Primitives
RectR ℝ ℝ2 ℝ2
| Circle ℝ
| PolygonR ℝ [ℝ2]
-- (Rounded) CSG
| Complement2 SymbolicObj2
| UnionR2 ℝ [SymbolicObj2]
| DifferenceR2 ℝ [SymbolicObj2]
| IntersectR2 ℝ [SymbolicObj2]
-- Simple transforms
| Translate2 ℝ2 SymbolicObj2
| Scale2 ℝ2 SymbolicObj2
| Rotate2 ℝ SymbolicObj2
-- Boundary mods
| Outset2 ℝ SymbolicObj2
| Shell2 ℝ SymbolicObj2
-- Misc
| EmbedBoxedObj2 BoxedObj2
deriving Show
-- | A symbolic 3D format!
data SymbolicObj3 =
-- Primitives
Rect3R ℝ ℝ3 ℝ3
| Sphere ℝ
| Cylinder ℝ ℝ ℝ -- h r1 r2
-- (Rounded) CSG
| Complement3 SymbolicObj3
| UnionR3 ℝ [SymbolicObj3]
| IntersectR3 ℝ [SymbolicObj3]
| DifferenceR3 ℝ [SymbolicObj3]
-- Simple transforms
| Translate3 ℝ3 SymbolicObj3
| Scale3 ℝ3 SymbolicObj3
| Rotate3 (ℝ,ℝ,ℝ) SymbolicObj3
-- Boundary mods
| Outset3 ℝ SymbolicObj3
| Shell3 ℝ SymbolicObj3
-- Misc
| EmbedBoxedObj3 BoxedObj3
-- 2D based
| ExtrudeR ℝ SymbolicObj2 ℝ
| ExtrudeRotateR ℝ ℝ SymbolicObj2 ℝ
| ExtrudeRM
ℝ -- ^ rounding radius
(Maybe (ℝ -> ℝ)) -- ^ twist
(Maybe (ℝ -> ℝ)) -- ^ scale
(Maybe (ℝ -> ℝ2)) -- ^ translate
SymbolicObj2 -- ^ object to extrude
(Either ℝ (ℝ2 -> ℝ)) -- ^ height to extrude to
| RotateExtrude
ℝ -- ^ Angle to sweep to
(Maybe ℝ) -- ^ Loop or path (rounded corner)
(Either ℝ2 (ℝ -> ℝ2)) -- ^ translate function
SymbolicObj2 -- ^ object to extrude
| ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2
deriving Show
-- | Rectilinear 2D set
type Rectilinear2 = [Box2]
-- | Rectilinear 2D set
type Rectilinear3 = [Box3]
-- | Make ALL the functions Showable!
-- This is very handy when testing functions in interactive mode...
instance Show (a -> b) where
show f = "<function>"
-- | Now for something that makes me a bad person...
-- I promise I'll use it for good, not evil!
-- I don't want to reparse the program arguments
-- everytime I want to know if XML errors are needed.
{-# NOINLINE xmlErrorOn #-}
xmlErrorOn :: IORef Bool
xmlErrorOn = unsafePerformIO $ newIORef False
errorMessage :: Int -> String -> IO()
errorMessage line msg = do
useXML <- readIORef xmlErrorOn
let
msg' = "At line <line>" ++ show line ++ "</line>:" ++ msg
-- dropXML inTag (x:xs)
dropXML inQuote False ('"':xs) = '"':dropXML (not inQuote) False xs
dropXML True _ ( x :xs) = x:dropXML True False xs
dropXML False False ('<':xs) = dropXML False True xs
dropXML False True ('>':xs) = dropXML False False xs
dropXML inQuote True ( _ :xs) = dropXML inQuote True xs
dropXML inQuote False ( x :xs) = x:dropXML inQuote False xs
dropXML _ _ [] = []
if useXML
then putStrLn $ "<error>" ++ msg' ++ "</error>"
else putStrLn $ dropXML False False $ msg'
return ()