-
Notifications
You must be signed in to change notification settings - Fork 0
/
Main.elm
196 lines (167 loc) · 6.67 KB
/
Main.elm
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
191
192
193
194
195
196
module RoofCalculator where
import Graphics.Element (..)
import Graphics.Input (..)
import Signal (channel, Channel, Signal, map4, send, (<~), (~), subscribe)
import Signal
import List
import Text (asText)
import Text
import Math.Vector3 (Vec3, vec3, dot, cross, toRecord, length)
import String
import Dict
import Dict (Dict)
import Json.Encode
import Http (Response(..))
import HttpHelpers (..)
import WebGL
-- Graphics
import Graphics.Collage (..)
import Color (..)
import Window
-- HTML form
import Html
import Html (..)
import Html.Attributes (..)
import Html.Events (..)
import Basics
-- The 3D view module
import ThreeDView (..)
-- Represents application state
type alias Params = { w : Float
, l : Float
, h : Float
}
main : Signal Html
main = draw <~ inputs ~ Window.dimensions ~ getTextures textures
inputs = (,,) <~ (makeInput "W" (toString initialParams.w))
~ (makeInput "L" (toString initialParams.l))
~ (makeInput "H" (toString initialParams.h))
textures = ["roof", "wall", "ruler", "rise", "end-run", "side-run"]
getTextures : List String -> Signal (Response (String -> WebGL.Texture))
getTextures names =
let requestSignals = List.map makeReqSignal names -- List (Signal (Response (String, WebGL.Texture)))
makeReqSignal name = "/" ++ name ++ "-texture.png" |> WebGL.loadTexture |> tagResponse name
getUnsafe list key = case Dict.get key (Dict.fromList list) of
Just value -> value
in requestSignals |> combineSignals
|> Signal.map (combineResponses >> mapResponse getUnsafe)
paramSignal =
let parseValue v = case String.toFloat v of
Err e -> defaultValue
Ok newV -> newV
getFirst ((wv,b), (lv,d), (hv,f)) =
{w = parseValue wv, l = parseValue lv, h = parseValue hv }
in getFirst <~ inputs
draw : ((String, Html), (String, Html), (String, Html)) -> (Int, Int)
-> Response (String -> WebGL.Texture) -> Html
draw ((w, wEl), (l, lEl), (h, hEl)) (winWidth, winHeight) textureRequests =
let params = Params (parse w) (parse l) (parse h)
parse str = case (String.toFloat str) of
Ok res -> res
Err err -> 0
n = northRoof params
s = southRoof params
e = eastRoof params
a = ridgeAngle n s
ridgeDiagWidth = 400
ridgeDiagrams = container winWidth (ridgeDiagWidth // 2) middle <|
ridgeDiagram ridgeDiagWidth "Ridge angle" (ridgeAngle n s) `beside`
ridgeDiagram ridgeDiagWidth "Hip angle" (ridgeAngle n e)
forms = Html.form [class "form-horizontal col-xs-6"] [
bsFormGroup "Side run (meters):" "W" wEl,
bsFormGroup "End run (meters):" "L" lEl,
bsFormGroup "Rise (meters):" "H" hEl
]
threeDView = case textureRequests of
Success textures ->
div [class "col-xs-6 bordered"] [
fromElement <| make3DView textures (winWidth // 2, winWidth // 2) params
]
Waiting ->
div [] [text "Waiting for texture"]
Failure errNo msg -> div [] [text "Failed to fetch textures"]
bsFormGroup : String -> String -> Html -> Html
bsFormGroup lbl myId formControl =
div [class "form-group row"] [
label [class "control-label col-sm-4", for myId] [ text lbl ],
div [class "col-sm-8"] [ formControl ]
]
in div []
[ div [class "row"] [forms , threeDView]
, div [class "row"] [fromElement ridgeDiagrams]
]
makeInput : String -> String -> Signal (String, Html)
makeInput myId defaultValue =
let updateChannel = channel defaultValue
valueToHtml v =
input [type' "text"
, class "form-control"
, id myId
, placeholder ""
, tabindex 0
, value v
, on "input" targetValue (send updateChannel)] []
in (\v -> (v, valueToHtml v)) <~ subscribe updateChannel
-- Calculation functions
-- There are north, east and south - facing roof sections
-- The x-axis points east, y north and z up
northRoof : Params -> Vec3
northRoof p = vec3 0 p.h p.w
southRoof : Params -> Vec3
southRoof p = vec3 0 (-p.h) p.w
eastRoof : Params -> Vec3
eastRoof p = vec3 p.h 0 p.l
ridgeAngle : Vec3 -> Vec3 -> Float
ridgeAngle r1 r2 = pi - acos (dot r1 r2 / length r1 / length r2)
-- -- Drawing functions
showAngle : Float -> Element
showAngle angle = Text.plainText
<| toString (round <| angle / degrees 1) ++ " degrees"
pointAt : Float -> Float -> (Float, Float)
pointAt radius theta = fromPolar (radius, theta - pi / 2)
arc : Float -> Float -> Path
arc radius angle =
let maxN = 20
thetaAtN n = angle * (n / maxN - 0.5)
in List.map (thetaAtN >> pointAt radius) [0 .. maxN]
ridgeDiagram : Int -> String -> Float -> Element
ridgeDiagram width name angle =
let nameLabel = toForm <| Text.rightAligned
<| Text.bold
<| Text.fromString name
angleLabel = toForm <| showAngle angle
diagRoof = path [pointAt 50 (-0.5 * angle)
, (0, 0), pointAt 50 (0.5 * angle) ]
diagArc = arc 30 angle
in collage (width // 2) (width // 2) <| List.map (scale (toFloat width / 300) << move (0, 40))
[ move (0, toFloat width / 12) nameLabel
, traced { defaultLine | width <- 10 } diagRoof
, traced { defaultLine | width <- 5 } diagArc
, move (3, negate (toFloat width / 6)) angleLabel]
-- Integration with browser
port initialLocation : String
-- For debugging
port initialLocation = "h=2.2&l=3.55&w=3.95"
defaultValue = 3.5
parseParams : String -> Params
parseParams search =
let params = String.split "&" search
parseParam param =
let [key, stringValue] = case String.split "=" param of
[a, b] -> [a, b]
x -> [key, toString defaultValue]
value = case (String.toFloat stringValue) of
Ok v -> v
Err s -> defaultValue
in (key, value)
dict = Dict.fromList <| List.map parseParam params
getKey x = case Dict.get x dict of
Just v -> v
Nothing -> defaultValue
in { w = getKey "w", l = getKey "l", h = getKey "h" }
paramToString : Params -> String
paramToString {w, l, h} = "w=" ++ toString w ++ "&l=" ++ toString l ++ "&h=" ++ toString h
initialParams : Params
initialParams = parseParams initialLocation
port location : Signal String
port location = paramToString <~ paramSignal