module Here4.Primitive.Sphere exposing (spheres, skySphere, cloudsSphere, fogMountainsSphere, sphere)
import Here4.Appearance exposing (..)
import Here4.Body exposing (Oriented, Visible)
import Here4.Orientation as Orientation
import List exposing (drop, concat, map, map2)
import Math.Vector2 exposing (Vec2)
import Math.Vector3 exposing (..)
import Math.Vector4 exposing (Vec4, vec4)
import Math.Matrix4 as M4 exposing (..)
import Shaders.Clouds exposing (clouds)
import Shaders.Sky exposing (sky)
import Shaders.FogMountains exposing (fogMountains)
import Shaders.WorldVertex exposing (Vertex, worldVertex)
import WebGL exposing (..)
spheres :
Int
-> Shader {} ShaderPerception { elm_FragColor : Vec4, elm_FragCoord : Vec2, clipPosition : Vec4 }
-> List (Oriented (Visible {}))
spheres n fragmentShader =
map (always (sphere worldVertex fragmentShader)) (List.range 0 n)
skySphere : Perception -> List Entity
skySphere =
appearSphere worldVertex sky
cloudsSphere : Perception -> List Entity
cloudsSphere =
appearSphere worldVertex clouds
fogMountainsSphere : Oriented (Visible {})
fogMountainsSphere =
sphere worldVertex fogMountains
sphere : Shader Vertex ShaderPerception a -> Shader {} ShaderPerception a -> Oriented (Visible {})
sphere vertexShader fragmentShader =
let
appear =
appearSphere vertexShader fragmentShader
in
{ scale = vec3 1 1 1
, position = vec3 0 0 0
, orientation = Orientation.initial
, appear = appear
}
appearSphere : Shader Vertex ShaderPerception a -> Shader {} ShaderPerception a -> Appearance
appearSphere vertexShader fragmentShader p =
let
resolution =
vec3 (toFloat p.windowSize.width) (toFloat p.windowSize.height) 0
s =
p.globalTime
iHMD =
if p.cameraVR then
1.0
else
0.0
in
[ entity vertexShader
fragmentShader
sphereMesh
{ iResolution = resolution
, iGlobalTime = s
, iHMD = iHMD
, iLensDistort = p.lensDistort
, modelViewProjectionMatrix = M4.mul p.perspective p.lookAt
, modelMatrix = M4.identity
, viewPosition = p.cameraPos
, lightPosition = p.lightPosition
, ambientColor = p.ambientColor
}
]
unfold : Int -> (a -> a) -> a -> List a
unfold n f x =
if n == 0 then
[]
else
let
res =
f x
in
(res :: unfold (n - 1) f res)
zip3 : List a -> List b -> List c -> List ( a, b, c )
zip3 xs ys zs =
case ( xs, ys, zs ) of
( x :: xs1, y :: ys1, z :: zs1 ) ->
( x, y, z ) :: zip3 xs1 ys1 zs1
_ ->
[]
rotY : Float -> Mat4
rotY n =
makeRotate (2 * pi / n) (vec3 0 1 0)
rotZ : Float -> Mat4
rotZ n =
makeRotate (-2 * pi / n) (vec3 0 0 1)
rotBoth : Float -> Vertex -> Vertex
rotBoth n x =
let
position =
M4.transform (rotY n) x.position
in
{ x
| position = position
, normal = position
, coord = M4.transform (rotZ n) x.coord
}
rotMercator : Float -> Vertex -> Vertex
rotMercator n v =
let
position =
M4.transform (rotY n) v.position
in
{ v
| position = position
, normal = position
, coord = vec3 (getX v.coord + (1.0 / n)) (getY v.coord) 0
}
seven : Vertex -> List Vertex
seven =
unfold 7 (rotMercator 8)
eights : Vertex -> ( List Vertex, List Vertex )
eights x =
let
x7 =
seven x
in
( x :: x7, x7 ++ [ x ] )
unfoldMercator : Int -> Vertex -> List Vertex
unfoldMercator n =
unfold (n - 1) (rotMercator (toFloat n))
verticesMercator : Int -> Vertex -> ( List Vertex, List Vertex )
verticesMercator n x =
let
xs =
unfoldMercator n x
in
( x :: xs, xs ++ [ x ] )
sphereMesh : Mesh Vertex
sphereMesh =
let
white =
vec4 1 1 1 1
nlat q =
let
x =
sqrt (1 - q * q)
position =
vec3 x (-q) 0
in
{ position = position
, normal = position
, coord = vec3 0 ((1 - q) / 2) 0
, color = white
}
slat q =
let
x =
sqrt (1 - q * q)
position =
vec3 x q 0
in
{ position = position
, normal = position
, color = white
, coord = vec3 0 ((1 + q) / 2) 0
}
nband q1 q2 =
let
( band10, band11 ) =
verticesMercator 20 (nlat q1)
( band20, band21 ) =
verticesMercator 20 (nlat q2)
band1U =
zip3 band10 band11 band20
band1L =
zip3 band20 band11 band21
in
band1U ++ band1L
sband q1 q2 =
let
( band10, band11 ) =
verticesMercator 20 (slat q1)
( band20, band21 ) =
verticesMercator 20 (slat q2)
band1U =
zip3 band10 band11 band20
band1L =
zip3 band20 band11 band21
in
band1U ++ band1L
qs0 n =
map (\x -> (toFloat x) / (toFloat n)) (List.range 0 n)
qs =
map (sin << (\x -> x * pi / 2)) (qs0 30)
nbands =
concat (map2 nband qs (drop 1 qs))
sbands =
concat (map2 sband qs (drop 1 qs))
in
triangles <| nbands ++ sbands