119 lines
4.0 KiB
Elm
119 lines
4.0 KiB
Elm
module DrawingBoard exposing (Point, Stroke, Msg(..), update, viewCanvas, addPendingPointToStrokes)
|
|
|
|
import Html exposing (Html)
|
|
import Html.Attributes exposing (id)
|
|
import Html.Events.Extra.Mouse as Mouse
|
|
import Canvas exposing (..)
|
|
import Canvas.Settings as CS
|
|
import Canvas.Settings.Line as CS
|
|
import Color
|
|
import List exposing (map, map2, head, tail, reverse)
|
|
import Tuple exposing (pair)
|
|
import Maybe as M
|
|
import Time
|
|
import Task
|
|
|
|
type alias Point = (Float, Float)
|
|
|
|
type alias Stroke = {
|
|
xs : List Float
|
|
, ys : List Float
|
|
, times : List Float
|
|
, startTime : Float
|
|
}
|
|
|
|
emptyStroke : Stroke
|
|
emptyStroke = {xs = [], ys = [], times = [], startTime = 0}
|
|
|
|
type Msg = AddStroke Point
|
|
| UpdatePending Point
|
|
| EndStroke
|
|
| GotStartTime Time.Posix Stroke
|
|
| GotPendingPointTime Time.Posix Point
|
|
|
|
{-| Update the stroke list based on mouse/touch events -}
|
|
update : Msg -> List Stroke -> Maybe Point -> ((List Stroke, Maybe Point), Cmd Msg)
|
|
update msg strokes pendingPoint =
|
|
case msg of
|
|
AddStroke point -> addEmptyStroke point strokes
|
|
UpdatePending point ->
|
|
case pendingPoint of
|
|
Just _ -> ((strokes, Just point), Cmd.none)
|
|
Nothing -> ((strokes, Nothing), Cmd.none)
|
|
EndStroke -> ((strokes, Nothing), Cmd.none)
|
|
GotStartTime time stroke -> ((strokes ++ [addStartTimeToStroke time stroke], pendingPoint), Cmd.none)
|
|
GotPendingPointTime time point -> ((updateStrokeWithTime strokes point time, pendingPoint), Cmd.none)
|
|
|
|
applyToLastStroke : (Stroke -> Stroke) -> List Stroke -> List Stroke
|
|
applyToLastStroke func strokes =
|
|
let
|
|
reverseStrokes = reverse strokes
|
|
lastStroke = head reverseStrokes
|
|
strokesWithoutLastStroke = Maybe.map reverse <| tail reverseStrokes
|
|
in
|
|
(M.withDefault [] strokesWithoutLastStroke) ++ [func (M.withDefault emptyStroke lastStroke)]
|
|
|
|
addEmptyStroke : Point -> List Stroke -> ((List Stroke, Maybe Point), Cmd Msg)
|
|
addEmptyStroke point strokes =
|
|
((strokes, Just point), Task.perform (\t -> GotStartTime t emptyStroke) Time.now)
|
|
|
|
processTime : Time.Posix -> Float
|
|
processTime time = toFloat <| (Time.posixToMillis time) // 1000
|
|
|
|
addStartTimeToStroke : Time.Posix -> Stroke -> Stroke
|
|
addStartTimeToStroke time stroke = {stroke | startTime = processTime time}
|
|
|
|
updateStrokeWithTime : List Stroke -> Point -> Time.Posix -> List Stroke
|
|
updateStrokeWithTime strokes (x,y) time =
|
|
let
|
|
updateLastStroke stroke =
|
|
{ stroke |
|
|
xs = stroke.xs ++ [x]
|
|
, ys = stroke.ys ++ [y]
|
|
, times = stroke.times ++ [processTime time]
|
|
}
|
|
|
|
in
|
|
applyToLastStroke updateLastStroke strokes
|
|
|
|
addPendingPointToStrokes : Maybe Point -> Cmd Msg
|
|
addPendingPointToStrokes point =
|
|
case point of
|
|
(Nothing) -> Cmd.none
|
|
(Just (x,y)) -> Task.perform (\t -> GotPendingPointTime t (x,y)) Time.now
|
|
|
|
{-| Convert a stroke into a viewable shape for the canvas -}
|
|
strokeToPath : Stroke -> Shape
|
|
strokeToPath {xs, ys} =
|
|
let
|
|
start : Point
|
|
start = M.map2 pair (head xs) (head ys)
|
|
|> M.withDefault (0, 0)
|
|
|
|
rest : List PathSegment
|
|
rest = M.map2 pair (tail xs) (tail ys)
|
|
|> M.map (\(list1, list2) -> map2 pair list1 list2)
|
|
|> M.withDefault []
|
|
|> map lineTo
|
|
in
|
|
path start rest
|
|
|
|
{-| Settings for all strokes to be drawn on the canvas -}
|
|
strokeStyle : List CS.Setting
|
|
strokeStyle = [ CS.stroke Color.black
|
|
, CS.lineWidth 2.0
|
|
, CS.lineCap CS.RoundCap
|
|
, CS.lineJoin CS.RoundJoin
|
|
]
|
|
|
|
{-| Generate a canvas based on the current strokes -}
|
|
viewCanvas : List Stroke -> Html Msg
|
|
viewCanvas strokes = Canvas.toHtml (500, 500)
|
|
[ id "canvas"
|
|
, Mouse.onDown (\e -> AddStroke e.offsetPos)
|
|
, Mouse.onMove (\e -> UpdatePending e.offsetPos)
|
|
, Mouse.onUp (\_ -> EndStroke)
|
|
]
|
|
[ clear (0,0) 500 500
|
|
, shapes strokeStyle (map strokeToPath strokes)
|
|
] |