Skip to content

Instantly share code, notes, and snippets.

@BraxtonI

BraxtonI/Common.elm

Last active July 14, 2020 05:42
Show Gist options
  • Save BraxtonI/1a9fc0c56a03254de908c97b6deb1250 to your computer and use it in GitHub Desktop.
Save BraxtonI/1a9fc0c56a03254de908c97b6deb1250 to your computer and use it in GitHub Desktop.
Download ZIP
Photo Groove
Raw
Common.elm
module Common exposing (urlPrefix, Photo)
urlPrefix : String
urlPrefix =
"http://elm-in-action.com/"
type alias Photo =
{ title : String
, url : String
, size : Int
, relatedUrls : List String
}
Raw
Index.html
<!doctype html>
<html>
<head>
<link rel="stylesheet" href="http://elm-in-action.com/styles.css">
<link rel="stylesheet" href="http://elm-in-action.com/range-slider.css">
<script src="http://elm-in-action.com/range-slider.js"></script>
<script>
class RangeSlider extends HTMLElement {
connectedCallback() {
var input = document.createElement("input");
this.appendChild(input);
var jsr = new JSR(input, {
max: this.max,
values: [this.val],
sliders: 1,
grid: false
});
var rangeSliderNode = this;
jsr.addEventListener("update", function(elem, value) {
var event = new CustomEvent("slide", {
detail: {userSlidTo: value}
});
rangeSliderNode.dispatchEvent(event);
});
}
}
window.customElements.define("range-slider", RangeSlider);
</script>
</head>
<body>
<div id="app"></div>
<script src="http://elm-in-action.com/pasta.js"></script>
<script src="app.js"></script>
<script>
var app = Elm.Main.init({node: document.getElementById("app"), flags: Pasta.version});
app.ports.setFilters.subscribe(function(options) {
requestAnimationFrame(function() {
Pasta.apply(document.getElementById("main-canvas"), options);
});
});
Pasta.addActivityListener(function(activity) {
console.log("Got some activity to send to Elm:", activity);
app.ports.activityChanges.send(activity);
});
</script>
</body>
</html>
Raw
Main.elm
module Main exposing (main)
import Browser exposing (Document)
import Browser.Navigation as Nav
import Html exposing (Html, a, footer, h1, li, nav, text, ul)
import Html.Attributes exposing (classList, href)
import Html.Lazy exposing (lazy)
import PhotoFolders as Folders
import PhotoGallery as Gallery
import Url exposing (Url)
import Url.Parser as Parser exposing ((</>), Parser, s)
main : Program Float Model Msg
main =
Browser.application
{ init = init
, view = view
, update = update
, subscriptions = subscriptions
, onUrlChange = ChangedUrl
, onUrlRequest = ClickedLink
}
init : Float -> Url -> Nav.Key -> ( Model, Cmd Msg )
init version url key =
updateUrl url
{ page = NotFound
, galleryModel = Tuple.first (Gallery.init version)
, foldersModel = Tuple.first (Folders.init Nothing)
, key = key
, version = version
}
type alias Model =
{ page : Page
, galleryModel : Gallery.Model
, foldersModel : Folders.Model
, key : Nav.Key
, version : Float
}
type Page
= FoldersPage
| GalleryPage
| NotFound
type Route
= Gallery
| Folders
| SelectedPhoto String
view : Model -> Document Msg
view model =
let
content =
case model.page of
FoldersPage ->
Folders.view model.foldersModel
|> Html.map GotFoldersMsg
GalleryPage ->
Gallery.view model.galleryModel
|> Html.map GotGalleryMsg
NotFound ->
text "Not Found"
in
{ title = "Photo Groove, SPA Style"
, body =
[ lazy viewHeader model.page
, content
, viewFooter
]
}
viewHeader : Page -> Html Msg
viewHeader page =
let
logo =
h1 [] [ text "Photo Groove" ]
links =
ul []
[ navLink Folders { url = "/", caption = "Folders" }
, navLink Gallery { url = "/gallery", caption = "Gallery" }
]
navLink : Route -> { url : String, caption : String } -> Html msg
navLink route { url, caption } =
li
[ classList
[ ( "active"
, isActive { link = route, page = page }
)
]
]
[ a [ href url ] [ text caption ] ]
in
nav [] [ logo, links ]
parser : Parser (Route -> a) a
parser =
Parser.oneOf
[ Parser.map Folders Parser.top
, Parser.map Gallery (s "gallery")
, Parser.map SelectedPhoto (s "photos" </> Parser.string)
]
isActive : { link : Route, page : Page } -> Bool
isActive { link, page } =
case ( link, page ) of
( Gallery , GalleryPage ) -> True
( Gallery , _ ) -> False
( Folders , FoldersPage ) -> True
( Folders , _ ) -> False
( SelectedPhoto _, _ ) -> False
viewFooter : Html msg
viewFooter =
footer []
[ text "One is never alone with a rubber duck. -Douglas Adams" ]
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
ClickedLink urlRequest ->
case urlRequest of
Browser.External href ->
( model, Nav.load href )
Browser.Internal url ->
( model, Nav.pushUrl model.key (Url.toString url) )
ChangedUrl url ->
updateUrl url model
GotFoldersMsg foldersMsg ->
case model.page of
FoldersPage ->
toFolders model (Folders.update foldersMsg model.foldersModel)
_ ->
( model, Cmd.none )
GotGalleryMsg galleryMsg ->
case model.page of
GalleryPage ->
toGallery model (Gallery.update galleryMsg model.galleryModel)
_ ->
( model, Cmd.none )
type Msg
= ClickedLink Browser.UrlRequest
| ChangedUrl Url
| GotFoldersMsg Folders.Msg
| GotGalleryMsg Gallery.Msg
toFolders : Model -> ( Folders.Model, Cmd Folders.Msg ) -> ( Model, Cmd Msg )
toFolders model ( folders, cmd ) =
( { model | page = FoldersPage, foldersModel = folders }
, Cmd.map GotFoldersMsg cmd
)
toGallery : Model -> ( Gallery.Model, Cmd Gallery.Msg ) -> ( Model, Cmd Msg )
toGallery model ( gallery, cmd ) =
( { model | page = GalleryPage, galleryModel = gallery }
, Cmd.map GotGalleryMsg cmd
)
updateUrl : Url -> Model -> ( Model, Cmd Msg )
updateUrl url model =
case Parser.parse parser url of
Just Gallery ->
toGallery model <|
let
initGalleryModel =
(Gallery.init model.version)
in
-- if the gallery has not been initialized, proceed with regular initialization
-- if the gallery has been initialized, model.galleryModel has the previous build, and should be used
-- to reload the page via Gallery.reload, which also called Gallery.applyFilters to load the main-canvas
if model.galleryModel == Tuple.first initGalleryModel then
initGalleryModel
else
Gallery.reload model.galleryModel
Just Folders ->
toFolders model <|
let
initFoldersModel =
(Folders.init Nothing)
in
-- if the folders page has not been initialized, proceed with regular initialization
-- if the folders page has been initialized, model.foldersModel has the previous build, and should be used instead
if model.foldersModel == Tuple.first initFoldersModel then
initFoldersModel
else
( model.foldersModel, Cmd.none )
Just (SelectedPhoto filename) ->
let
foldersModel = model.foldersModel
in
-- Update model.foldersModel.selectPhotoUrl to filename
toFolders model ( { foldersModel | selectedPhotoUrl = (Just filename) }, Cmd.none )
Nothing ->
( { model | page = NotFound }, Cmd.none )
subscriptions : Model -> Sub Msg
subscriptions model =
case model.page of
GalleryPage ->
Gallery.subscriptions model.galleryModel
|> Sub.map GotGalleryMsg
_ ->
Sub.none
Raw
PhotoFolders.elm
module PhotoFolders exposing (Model, Msg, update, view, init)
import Common exposing (urlPrefix, Photo)
import Dict exposing (Dict)
import Html exposing (..)
import Html.Attributes exposing (class, href, src)
import Html.Events exposing (onClick)
import Http
import Json.Decode as Decode exposing (Decoder, int, list, string)
import Json.Decode.Pipeline exposing (required)
type Folder
= Folder
{ name : String
, photoUrls : List String
, subfolders : List Folder
, expanded : Bool
}
type alias Model =
{ selectedPhotoUrl : Maybe String
, photos : Dict String Photo
, root : Folder
}
initialModel : Model
initialModel =
{ selectedPhotoUrl = Nothing
, photos = Dict.empty
, root =
Folder
{ name = "Loading..."
, expanded = True
, photoUrls = []
, subfolders = []
}
}
init : Maybe String -> ( Model, Cmd Msg )
init selectedFilename =
( { initialModel | selectedPhotoUrl = selectedFilename }
, Http.get
{ url = "http://elm-in-action.com/folders/list"
, expect = Http.expectJson LoadPage modelDecoder
}
)
modelDecoder : Decoder Model
modelDecoder =
Decode.map2
(\photos root ->
{ photos = photos, root = root, selectedPhotoUrl = Nothing }
)
modelPhotosDecoder
folderDecoder
type Msg
= SelectPhotoUrl String
| LoadPage (Result Http.Error Model)
| ToggleExpanded FolderPath
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
ToggleExpanded path ->
( { model | root = toggleExpanded path model.root }, Cmd.none )
SelectPhotoUrl url ->
( { model | selectedPhotoUrl = Just url }, Cmd.none )
LoadPage (Ok newModel) ->
( { newModel | selectedPhotoUrl = model.selectedPhotoUrl }, Cmd.none )
LoadPage (Err _) ->
( model, Cmd.none )
view : Model -> Html Msg
view model =
let
photoByUrl : String -> Maybe Photo
photoByUrl url =
Dict.get url model.photos
selectedPhoto : Html Msg
selectedPhoto =
case Maybe.andThen photoByUrl model.selectedPhotoUrl of
Just photo ->
viewSelectedPhoto photo
Nothing ->
text ""
in
div [ class "content" ]
[ div [ class "folders" ]
[ viewFolder End model.root
]
, div [ class "selected-photo" ] [ selectedPhoto ]
]
viewPhoto : String -> Html Msg
viewPhoto url =
a [ href ("/photos/" ++ url), class "photo", onClick (SelectPhotoUrl url) ]
[ text url ]
viewSelectedPhoto : Photo -> Html Msg
viewSelectedPhoto photo =
div
[ class "selected-photo" ]
[ h2 [] [ text photo.title ]
, img [ src (urlPrefix ++ "photos/" ++ photo.url ++ "/full") ] []
, span [] [ text (String.fromInt photo.size ++ "KB") ]
, h3 [] [ text "Related" ]
, div [ class "related-photos" ]
(List.map viewRelatedPhoto photo.relatedUrls)
]
viewRelatedPhoto : String -> Html Msg
viewRelatedPhoto url =
a [ href ("/photos/" ++ url) ]
[ img
[ class "related-photo"
, onClick (SelectPhotoUrl url)
, src (urlPrefix ++ "photos/" ++ url ++ "/thumb")
]
[]
]
viewFolder : FolderPath -> Folder -> Html Msg
viewFolder path (Folder folder) =
let
viewSubfolder : Int -> Folder -> Html Msg
viewSubfolder index subfolder =
viewFolder (appendIndex index path) subfolder
folderLabel =
label [ onClick (ToggleExpanded path) ] [ text folder.name ]
in
if folder.expanded then
let
contents =
List.append
(List.indexedMap viewSubfolder folder.subfolders)
(List.map viewPhoto folder.photoUrls)
in
div [ class "folder expanded" ]
[ folderLabel
, div [ class "contents" ] contents
]
else
div [ class "folder collapsed" ] [ folderLabel ]
appendIndex : Int -> FolderPath -> FolderPath
appendIndex index path =
case path of
End ->
Subfolder index End
Subfolder subfolderIndex remainingPath ->
Subfolder subfolderIndex (appendIndex index remainingPath)
type FolderPath
= End
| Subfolder Int FolderPath
toggleExpanded : FolderPath -> Folder -> Folder
toggleExpanded path (Folder folder) =
case path of
End ->
Folder { folder | expanded = not folder.expanded }
Subfolder targetIndex remainingPath ->
let
subfolders : List Folder
subfolders =
List.indexedMap transform folder.subfolders
transform : Int -> Folder -> Folder
transform currentIndex currentSubfolder =
if currentIndex == targetIndex then
toggleExpanded remainingPath currentSubfolder
else
currentSubfolder
in
Folder { folder | subfolders = subfolders }
type alias JsonPhoto =
{ title : String
, size : Int
, relatedUrls : List String
}
jsonPhotoDecoder : Decoder JsonPhoto
jsonPhotoDecoder =
Decode.succeed JsonPhoto
|> required "title" string
|> required "size" int
|> required "related_photos" (list string)
finishPhoto : ( String, JsonPhoto ) -> ( String, Photo )
finishPhoto ( url, json ) =
( url
, { url = url
, size = json.size
, title = json.title
, relatedUrls = json.relatedUrls
}
)
fromPairs : List ( String, JsonPhoto ) -> Dict String Photo
fromPairs pairs =
pairs
|> List.map finishPhoto
|> Dict.fromList
photosDecoder : Decoder (Dict String Photo)
photosDecoder =
Decode.keyValuePairs jsonPhotoDecoder
|> Decode.map fromPairs
folderDecoder : Decoder Folder
folderDecoder =
Decode.succeed folderFromJson
|> required "name" string
|> required "photos" photosDecoder
|> required "subfolders" (Decode.lazy (\_ -> list folderDecoder))
folderFromJson : String -> Dict String Photo -> List Folder -> Folder
folderFromJson name photos subfolders =
Folder
{ name = name
, expanded = True
, subfolders = subfolders
, photoUrls = Dict.keys photos
}
modelPhotosDecoder : Decoder (Dict String Photo)
modelPhotosDecoder =
Decode.succeed modelPhotosFromJson
|> required "photos" photosDecoder
|> required "subfolders" (Decode.lazy (\_ -> list modelPhotosDecoder))
modelPhotosFromJson :
Dict String Photo
-> List (Dict String Photo)
-> Dict String Photo
modelPhotosFromJson folderPhotos subfolderPhotos =
List.foldl Dict.union folderPhotos subfolderPhotos
Raw
PhotoGallery.elm
port module PhotoGallery exposing (init, Model, Msg, subscriptions, update, view, reload)
import Browser
import Common exposing (urlPrefix, Photo)
import Html exposing (..)
import Html.Attributes as Attr exposing (checked, class, classList, id, name, src, title, type_)
import Html.Events exposing (on, onClick)
import Http
import Json.Decode exposing (Decoder, at, string, int, list, succeed)
import Json.Decode.Pipeline exposing (optional, required)
import Json.Encode as Encode
import Random
main : Program Float Model Msg
main =
Browser.element
{ init = init
, view = view
, update = update
, subscriptions = subscriptions
}
subscriptions : Model -> Sub Msg
subscriptions model =
activityChanges GotActivity
init : Float -> ( Model, Cmd Msg )
init flags =
let
activity =
"Initializing Pasta v" ++ String.fromFloat flags
in
( { initialModel | activity = activity }, initialCmd )
type alias Model =
{ status : Status
, activity : String
, chosenSize : ThumbnailSize
, hue : Int
, ripple : Int
, noise : Int
}
initialModel : Model
initialModel =
{ status = Loading
, activity = ""
, chosenSize = Medium
, hue = 5
, ripple = 5
, noise = 5
}
type Msg
= ClickedPhoto String
| ClickedSize ThumbnailSize
| ClickedSurpriseMe
| GotActivity String
| GotPhotos (Result Http.Error (List Photo))
| GotRandomPhoto Photo
| SlidHue Int
| SlidNoise Int
| SlidRipple Int
view : Model -> Html Msg
view model =
div [ class "content" ] <|
case model.status of
Loaded photos selectedUrl ->
viewLoaded photos selectedUrl model
Loading ->
[]
Errored errorMessage ->
[ text ("Error: " ++ errorMessage) ]
viewLoaded : List Photo -> String -> Model -> List (Html Msg)
viewLoaded photos selectedUrl model =
[ button
[ onClick ClickedSurpriseMe ]
[ text "Surprise Me!" ]
, div [ class "activity" ] [ text model.activity ]
, div [ class "filters" ]
[ viewFilter SlidHue "Hue" model.hue
, viewFilter SlidRipple "Ripple" model.ripple
, viewFilter SlidNoise "Noise" model.noise
]
, h3 [] [ text "Thumbnail Size:" ]
, div [ id "choose-size" ]
(List.map (viewSizeChooser model.chosenSize) [ Small, Medium, Large ])
, div [ id "thumbnails", class (sizeToString model.chosenSize) ]
(List.map (viewThumbnail selectedUrl) photos)
, canvas [ id "main-canvas", class "large" ] []
]
viewThumbnail : String -> Photo -> Html Msg
viewThumbnail selectedUrl thumb =
img
[ src (urlPrefix ++ thumb.url)
, title (thumb.title ++ " [" ++ String.fromInt thumb.size ++ " KB]")
, classList [ ( "selected", selectedUrl == thumb.url ) ]
, onClick (ClickedPhoto thumb.url)
]
[]
viewSizeChooser : ThumbnailSize -> ThumbnailSize -> Html Msg
viewSizeChooser chosenSize size =
label []
[ input [ type_ "radio", name "size", onClick (ClickedSize size) ,
if size == chosenSize then
checked True
else
checked False
] []
, text (sizeToString size)
]
sizeToString : ThumbnailSize -> String
sizeToString size =
case size of
Small ->
"small"
Medium ->
"med"
Large ->
"large"
type ThumbnailSize
= Small
| Medium
| Large
port setFilters : FilterOptions -> Cmd msg
port activityChanges : (String -> msg) -> Sub msg
type alias FilterOptions =
{ url : String
, filters : List { name : String, amount : Float }
}
photoDecoder : Decoder Photo
photoDecoder =
succeed Photo
|> optional "title" string "(untitled)"
|> required "url" string
|> required "size" int
|> optional "requiredUrl" (list string) []
type Status
= Loading
| Loaded (List Photo) String
| Errored String
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
GotRandomPhoto photo ->
applyFilters { model | status = selectUrl photo.url model.status }
ClickedPhoto url ->
applyFilters { model | status = selectUrl url model.status }
ClickedSize size ->
( { model | chosenSize = size }, Cmd.none )
ClickedSurpriseMe ->
case model.status of
Loaded (firstPhoto :: otherPhotos) _ ->
Random.uniform firstPhoto otherPhotos
|> Random.generate GotRandomPhoto
|> Tuple.pair model
Loaded [] _ ->
( model, Cmd.none )
Loading ->
( model, Cmd.none )
Errored errorMessage ->
( model, Cmd.none )
GotActivity activity ->
( { model | activity = activity }, Cmd.none )
GotPhotos (Ok photos) ->
applyFilters
{ model
| status =
case photos of
first :: rest ->
Loaded photos first.url
[] ->
Loaded [] ""
}
GotPhotos (Err httpError) ->
( { model | status = Errored "Server error!" }, Cmd.none )
SlidHue hue ->
applyFilters { model | hue = hue }
SlidRipple ripple ->
applyFilters { model | ripple = ripple }
SlidNoise noise ->
applyFilters { model | noise = noise }
applyFilters : Model -> ( Model, Cmd Msg )
applyFilters model =
case model.status of
Loaded photos selectedUrl ->
let
filters =
[ { name = "Hue", amount = toFloat model.hue / 11 }
, { name = "Ripple", amount = toFloat model.ripple / 11 }
, { name = "Noise", amount = toFloat model.noise / 11 }
]
url =
urlPrefix ++ "large/" ++ selectedUrl
in
( model, setFilters { url = url, filters = filters } )
Loading ->
( model, Cmd.none )
Errored errorMessage ->
( model, Cmd.none )
selectUrl : String -> Status -> Status
selectUrl url status =
case status of
Loaded photos _ ->
Loaded photos url
Loading ->
status
Errored errorMessage ->
status
initialCmd : Cmd Msg
initialCmd =
Http.get
{ url = "http://elm-in-action.com/photos/list.json"
, expect = Http.expectJson GotPhotos (list photoDecoder)
}
reload : Model -> (Model, Cmd Msg)
reload newModel =
applyFilters newModel
viewFilter : (Int -> Msg) -> String -> Int -> Html Msg
viewFilter toMsg name magnitude =
div [ class "filter-slider" ]
[ label [] [ text name ]
, rangeSlider
[ Attr.max "11"
, Attr.property "val" (Encode.int magnitude)
, onSlide toMsg
]
[]
, label [] [ text (String.fromInt magnitude) ]
]
rangeSlider attributes children =
node "range-slider" attributes children
onSlide : (Int -> msg) -> Attribute msg
onSlide toMsg =
at [ "detail", "userSlidTo" ] int
|> Json.Decode.map toMsg
|> on "slide"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment