Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Idea for making 3D objects
import Graphics.WebGL as GL
import Math.Vector3 as GL
import Math.Matrix4 as GL
type Point = {
x : Float,
y : Float,
z : Float
}
(<+>) p q = Point (p.x + q.x) (p.y + q.y) (p.z + q.z)
(<->) p q = Point (p.x - q.x) (p.y - q.y) (p.z - q.z)
data Triangle = Triangle Point Point Point
data Rectangle = Rectangle Triangle Triangle
data Top = Top Rectangle
data Bottom = Bottom Rectangle
data Front = Front Rectangle
data Back = Back Rectangle
data Left = Left Rectangle
data Right = Right Rectangle
data Cube = Cube Top Bottom Front Back Left Right
cube : Point -> Float -> Cube
cube center size =
let hs = size / 2
ftl = center <+> Point (-hs) (hs) (-hs)
ftr = center <+> Point (hs) (hs) (-hs)
fbr = center <+> Point (hs) (-hs) (-hs)
fbl = center <+> Point (-hs) (-hs) (-hs)
btl = center <+> Point (-hs) (hs) (hs)
btr = center <+> Point (hs) (hs) (hs)
bbr = center <+> Point (hs) (-hs) (hs)
bbl = center <+> Point (-hs) (-hs) (hs)
topf = Rectangle (Triangle ftl ftr btr) (Triangle btr btl ftl)
botf = Rectangle (Triangle fbl fbr bbr) (Triangle bbr bbl fbl)
frof = Rectangle (Triangle ftl fbl fbr) (Triangle fbr ftr ftl)
bacf = Rectangle (Triangle btr btl bbl) (Triangle bbl bbr btr)
leff = Rectangle (Triangle btl bbl fbl) (Triangle fbl ftl btl)
rigf = Rectangle (Triangle btr bbr fbr) (Triangle fbr ftr btr)
in Cube (Top topf) (Bottom botf) (Front frof) (Back bacf) (Left leff) (Right rigf)
scene : [GL.Entity] -> Element
scene = GL.webgl (400,400)
type Attribute = {
position : GL.Vec3
}
type Varying = {
vColor : GL.Vec3
}
type Uniform = {
matrix : GL.Mat4
}
triangleToMesh : Triangle -> [GL.Triangle Attribute]
triangleToMesh (Triangle p q r) =
[({ position = GL.vec3 p.x p.y p.z },
{ position = GL.vec3 q.x q.y q.z },
{ position = GL.vec3 r.x r.y r.z })]
rectangleToMesh : Rectangle -> [GL.Triangle Attribute]
rectangleToMesh (Rectangle a b) =
triangleToMesh a ++ triangleToMesh b
cubeToMesh : Cube -> [GL.Triangle Attribute]
cubeToMesh (Cube (Top topFace) (Bottom bottomFace) (Front frontFace) (Back backFace) (Left leftFace) (Right rightFace)) =
concatMap rectangleToMesh [topFace, bottomFace, frontFace, backFace, leftFace, rightFace]
drawMesh : Float -> [GL.Triangle Attribute] -> GL.Entity
drawMesh t mesh = GL.entity vertexShader fragmentShader mesh { matrix = GL.makeRotate t (GL.vec3 -1 1 1)}
drawTriangle : Float -> Triangle -> GL.Entity
drawTriangle t = drawMesh t << triangleToMesh
drawRectangle : Float -> Rectangle -> GL.Entity
drawRectangle t = drawMesh t << rectangleToMesh
drawCube : Float -> Cube -> GL.Entity
drawCube t = drawMesh t << cubeToMesh
vertexShader : GL.Shader Attribute Uniform Varying
vertexShader = [glsl|
attribute vec3 position;
uniform mat4 matrix;
varying vec3 vColor;
vec3 getColor (vec3 pos){
return normalize(vec3(1.0,1.0,1.0) - pos);
}
void main () {
gl_Position = matrix * vec4(position, 1.0);
vColor = getColor(position);
}
|]
fragmentShader : GL.Shader {} Uniform Varying
fragmentShader = [glsl|
precision mediump float;
varying vec3 vColor;
void main (){
gl_FragColor = vec4(vColor,1.0);
}
|]
testCube = cube (Point 0 0 0) 1
render : Float -> Element
render t = scene [drawCube t testCube]
angle = (*) 0.001 <~ foldp (+) 0 (fps 60)
main = render <~ angle
{- cube (Point 0 0 0) 1
Cube
(Top
(Rectangle
(Triangle
{ x = -0.5, y = 0.5 , z = -0.5 }
{ x = 0.5 , y = 0.5 , z = -0.5 }
{ x = 0.5 , y = 0.5 , z = 0.5 }
)
(Triangle
{ x = 0.5 , y = 0.5 , z = 0.5 }
{ x = -0.5, y = 0.5 , z = 0.5 }
{ x = -0.5, y = 0.5 , z = -0.5 }
)
)
)
(Bottom
(Rectangle
(Triangle
{ x = -0.5, y = -0.5, z = -0.5 }
{ x = 0.5 , y = -0.5, z = -0.5 }
{ x = 0.5 , y = -0.5, z = 0.5 }
)
(Triangle
{ x = 0.5 , y = -0.5, z = 0.5 }
{ x = -0.5, y = -0.5, z = 0.5 }
{ x = -0.5, y = -0.5, z = -0.5 }
)
)
)
(Front
(Rectangle
(Triangle
{ x = -0.5, y = 0.5 , z = -0.5 }
{ x = -0.5, y = -0.5, z = -0.5 }
{ x = 0.5 , y = -0.5, z = -0.5 }
)
(Triangle
{ x = 0.5 , y = -0.5, z = -0.5 }
{ x = 0.5 , y = 0.5 , z = -0.5 }
{ x = -0.5, y = 0.5 , z = -0.5 }
)
)
)
(Back
(Rectangle
(Triangle
{ x = 0.5 , y = 0.5 , z = 0.5 }
{ x = -0.5, y = 0.5 , z = 0.5 }
{ x = -0.5, y = -0.5, z = 0.5 }
)
(Triangle
{ x = -0.5, y = -0.5, z = 0.5 }
{ x = 0.5 , y = -0.5, z = 0.5 }
{ x = 0.5 , y = 0.5 , z = 0.5 }
)
)
)
(Left
(Rectangle
(Triangle
{ x = -0.5, y = 0.5 , z = 0.5 }
{ x = -0.5, y = -0.5, z = 0.5 }
{ x = -0.5, y = -0.5, z = -0.5 }
)
(Triangle
{ x = -0.5, y = -0.5, z = -0.5 }
{ x = -0.5, y = 0.5 , z = -0.5 }
{ x = -0.5, y = 0.5 , z = 0.5 }
)
)
)
(Right
(Rectangle
(Triangle
{ x = 0.5 , y = 0.5 , z = 0.5 }
{ x = 0.5 , y = -0.5, z = 0.5 }
{ x = 0.5 , y = -0.5, z = -0.5 }
)
(Triangle
{ x = 0.5 , y = -0.5, z = -0.5 }
{ x = 0.5 , y = 0.5 , z = -0.5 }
{ x = 0.5 , y = 0.5 , z = 0.5 }
)
)
)
-}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment