Click and Drag to move viewport

Main.elm

@@ -2,6 +2,7 @@ import Html exposing (..)
 import Html.App as App
 import Html.Attributes exposing (..)
 import Html.Events exposing (onClick)
+import Task
 
 import Layer
 import Viewer
@@ -30,11 +31,14 @@ type alias IndexedLayer =
 
 init : (Model, Cmd Msg)
 init =
-  ( { layers = []
-    , viewDesc = Viewer.init
-    , nextUid = 0
-    }
-  , Cmd.none)
+  let
+    (viewModel, viewCmd) = Viewer.init
+  in
+      ( { layers = []
+        , viewDesc = viewModel
+        , nextUid = 0
+        }
+      , Cmd.map ModifyView viewCmd)
 
 
 -- Update

Viewer.elm

@@ -1,32 +1,55 @@
 module Viewer exposing ( Model, Msg, init, update, view, subscriptions )
 
 import AnimationFrame
+import Debug exposing (log)
 import Html exposing (Html)
 import Html.Attributes exposing ( width, height )
 import Math.Matrix4 exposing (..)
 import Math.Vector2 exposing (..)
 import Math.Vector3 exposing (..)
+import Mouse
+import Task
 import Time exposing (Time)
 import WebGL exposing (..)
+import Window
 
 
 -- Model
 
+type alias Center = { x : Float, y : Float }
+
 type alias Model =
   { imageUrl : String
+  , dragging : Bool
+  , centerPos : Center
+  , dragStart : Mouse.Position
+  , posStart : Center
+  , size : Window.Size
   }
 
-init : Model
+init : (Model, Cmd Msg)
 init =
-  { imageUrl = ""
-  }
+  ( { imageUrl = ""
+    , dragging = False
+    , centerPos = { x = 0, y = 0 }
+    , dragStart = { x = 0, y = 0 }
+    , posStart = { x = 0, y = 0 }
+    , size = { width = 0, height = 0 }
+    }
+  , Task.perform (always Resize (0, 0)) Resize Window.size
+  )
 
 
 -- Update
 
 type Msg
   = ChangeImageUrl String
   | Tick Time
+  | PosChange Mouse.Position
+  | DragStart Mouse.Position
+  | DragStop Mouse.Position
+  | Resize Window.Size
+
 
 update : Msg -> Model -> Model
 update msg model =
@@ -35,36 +58,81 @@ update msg model =
         { model | imageUrl = newUrl }
       Tick elapsed ->
         model
-
+      PosChange pos ->
+        { model
+          | centerPos =
+            if model.dragging
+            then newCenter model pos
+            else model.centerPos
+        }
+      DragStart pos ->
+        { model
+          | dragging = True
+          , dragStart = pos
+          , posStart = model.centerPos
+        }
+      DragStop pos ->
+        { model | dragging = False }
+      Resize newSize ->
+        { model | size = newSize }
+
+
+newCenter : Model -> Mouse.Position -> Center
+newCenter model {x, y} =
+  let
+    dx = toFloat (model.dragStart.x - x)
+    dy = toFloat (model.dragStart.y - y)
+    scale = 4 / toFloat model.size.height
+    dx' = dx * scale
+    dy' = dy * scale
+  in
+      { x = model.posStart.x - dx'
+      , y = model.posStart.y - dy'
+      }
 
 subscriptions : Model -> Sub Msg
 subscriptions model =
-  AnimationFrame.diffs Tick
+  Sub.batch
+    [ AnimationFrame.diffs Tick
+    , Mouse.moves PosChange
+    , Mouse.downs DragStart
+    , Mouse.ups DragStop
+    , Window.resizes Resize
+    ]
 
 -- View
 
 type alias Vertex = { position : Vec3, color : Vec3 }
 
 mesh : Drawable Vertex
 mesh =
-  Triangle
-    [ ( Vertex (vec3 -1 1 0) (vec3 1 0 0)
-      , Vertex (vec3 -1 -1 0) (vec3 1 0 0)
-      , Vertex (vec3 1 -1 0) (vec3 1 0 0)
-      )
+  TriangleFan
+    [ Vertex (vec3 -1 1 0) (vec3 1 0 0)
+    , Vertex (vec3 -1 -1 0) (vec3 1 0 0)
+    , Vertex (vec3 1 -1 0) (vec3 1 0 0)
+    , Vertex (vec3 1 1 0) (vec3 1 0 0)
     ]
 
-perspective : Mat4
-perspective =
-  List.foldr mul Math.Matrix4.identity
-    [ makeOrtho2D -2 2 -2 2
-    , makeLookAt (vec3 0 0 0) (vec3 0 0 1) (vec3 0 1 0)
-    ]
+perspective : Center -> Window.Size -> Mat4
+perspective center size =
+  let
+    w = toFloat size.width
+    h = toFloat size.height
+    a = w / h
+  in
+      List.foldr mul Math.Matrix4.identity
+        [ makeOrtho2D (-2 * a) (2 * a) -2 2
+        , makeLookAt (vec3 center.x center.y 0) (vec3 center.x center.y 1) (vec3 0 1 0)
+        ]
 
 view : Model -> Html Msg
 view model =
-  WebGL.toHtml [ width 600, height 600 ]
-    [ render vertexShader fragmentShader mesh { perspective = perspective } ]
+  WebGL.toHtml [ width model.size.width, height model.size.height ]
+    [ render
+        vertexShader
+        fragmentShader
+        mesh
+        { perspective = perspective model.centerPos model.size } ]
 
 vertexShader : Shader { attr | position : Vec3, color : Vec3 } { u | perspective : Mat4 } { vcolor : Vec3 }
 vertexShader =

elm-package.json

@@ -13,6 +13,8 @@
         "elm-lang/animation-frame": "1.0.0 <= v < 2.0.0",
         "elm-lang/core": "4.0.1 <= v < 5.0.0",
         "elm-lang/html": "1.0.0 <= v < 2.0.0",
+        "elm-lang/mouse": "1.0.0 <= v < 2.0.0",
+        "elm-lang/window": "1.0.0 <= v < 2.0.0",
         "eskimoblood/elm-color-extra": "3.0.3 <= v < 4.0.0"
     },
     "elm-version": "0.17.0 <= v < 0.18.0"