diff --git a/Devfriendly.elm b/Devfriendly.elm index 90945d1..bdf50a4 100644 --- a/Devfriendly.elm +++ b/Devfriendly.elm @@ -7,6 +7,8 @@ import Json.Decode as Decode exposing (Decoder, field, list) import Json.Decode.Pipeline as Pipe exposing (decode, required, optional, optionalAt) import Http import Navigation +import Geolocation exposing (Location) +import Task exposing (attempt) -- PORTS @@ -27,6 +29,7 @@ type alias Model = , places : List Place , selectedTown : TownSlug , visitedTowns : List TownSlug + , userPosition : Maybe Coordinates } @@ -43,6 +46,84 @@ type alias Place = } +type alias Positionned a = + { a + | latitude : Float + , longitude : Float + } + + +type alias Coordinates = + { latitude : Float + , longitude : Float + } + + +distance : Positionned a -> Positionned b -> Float +distance p1 p2 = + let + r = + 6.371e6 + + lat1 = + degrees p1.latitude + + lat2 = + degrees p2.latitude + + deltaLat = + lat2 - lat1 + + deltaLong = + degrees (p2.longitude - p1.longitude) + + a = + sin (deltaLat / 2) + * sin (deltaLat / 2) + + cos lat1 + * cos lat2 + * sin (deltaLong / 2) + * sin (deltaLong / 2) + + c = + 2 * (atan2 (sqrt a) (sqrt (1 - a))) + in + r * c + + +lower : (a -> comparable) -> a -> a -> a +lower evaluate a b = + if ((evaluate a) <= evaluate b) then + a + else + b + + +bestOf : (a -> a -> a) -> List a -> Maybe a +bestOf better values = + case values of + [] -> + Nothing + + head :: [] -> + Just head + + head :: tail -> + Just + (List.foldr + better + head + tail + ) + + +closerTown : Positionned a -> List Town -> Maybe Town +closerTown position towns = + bestOf + (lower (distance position)) + towns + + -- UPDATE @@ -52,6 +133,8 @@ type Msg | GetTowns (Result Http.Error (List Town)) | GetPlaces (Result Http.Error (List Place)) | UrlChange Navigation.Location + | AttemptGeolocate + | Geolocate (Result Geolocation.Error Location) update : Msg -> Model -> ( Model, Cmd Msg ) @@ -68,7 +151,7 @@ update msg model = case town of Just town -> ( { model | selectedTown = townSlug } - , Cmd.batch (cmdsDisplayTown town model.visitedTowns) + , cmdsDisplayTown town model.visitedTowns ) Nothing -> @@ -127,6 +210,31 @@ update msg model = in ( { model | places = [] }, Cmd.none ) + AttemptGeolocate -> + ( model, (attempt Geolocate Geolocation.now) ) + + Geolocate (Err err) -> + let + _ = + Debug.log "error geolocating" err + in + ( model, Cmd.none ) + + Geolocate (Ok position) -> + case (closerTown position model.towns) of + Nothing -> + ( model, Cmd.none ) + + Just town -> + ( { model | selectedTown = slugifyTownName town.name } + , Cmd.batch + [ cmdsDisplayTown town model.visitedTowns + , slugifyTownName town.name + |> String.append "#" + |> Navigation.newUrl + ] + ) + -- VIEW @@ -149,7 +257,10 @@ viewMenu model = ) (List.sortBy .name model.towns) in - select [ id "towns", onChange TownOnChange ] townsOption + span [ class "townsSelector" ] + [ select [ id "towns", onChange TownOnChange ] townsOption + , img [ src "images/geolocate.svg", onClick AttemptGeolocate, height 18, alt "Geolocate" ] [] + ] view : Model -> Html Msg @@ -175,7 +286,7 @@ loadPlaces url = |> Http.send GetPlaces -cmdsDisplayTown : Town -> List TownSlug -> List (Cmd Msg) +cmdsDisplayTown : Town -> List TownSlug -> Cmd Msg cmdsDisplayTown town visitedTowns = let townSlug = @@ -186,10 +297,10 @@ cmdsDisplayTown town visitedTowns = in case isVisited of False -> - [ moveMap town, loadPlaces (placesUrlFor townSlug) ] + Cmd.batch [ moveMap town, loadPlaces (placesUrlFor townSlug) ] True -> - [ moveMap town ] + moveMap town @@ -326,8 +437,9 @@ main = , places = [] , selectedTown = townSlug , visitedTowns = [] + , userPosition = Nothing } - , Cmd.batch [ loadTowns townsUrl ] + , loadTowns townsUrl ) in Navigation.program UrlChange diff --git a/devfriendly.css b/devfriendly.css index 3ea9d01..fe24bb1 100644 --- a/devfriendly.css +++ b/devfriendly.css @@ -11,10 +11,17 @@ div#map { z-index: 1; } -select#towns { +.townsSelector { position: absolute; top: 8em; z-index: 2; +} + +.townsSelector * { + vertical-align: middle; +} + +select#towns { padding: 0; margin-left: 10px; background-color: white; diff --git a/elm-package.json b/elm-package.json index 9b4febf..13ffb40 100644 --- a/elm-package.json +++ b/elm-package.json @@ -10,6 +10,7 @@ "dependencies": { "NoRedInk/elm-decode-pipeline": "3.0.0 <= v < 4.0.0", "elm-lang/core": "5.1.1 <= v < 6.0.0", + "elm-lang/geolocation": "1.0.2 <= v < 2.0.0", "elm-lang/html": "2.0.0 <= v < 3.0.0", "elm-lang/http": "1.0.0 <= v < 2.0.0", "elm-lang/navigation": "2.1.0 <= v < 3.0.0", diff --git a/images/geolocate.svg b/images/geolocate.svg new file mode 100644 index 0000000..03d8427 --- /dev/null +++ b/images/geolocate.svg @@ -0,0 +1,45 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +