summaryrefslogtreecommitdiff
path: root/elm3/Lightbox.elm
blob: db19fc7848ab2dd06cb3a0e760ab5a4f3566a9b2 (plain)
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
port module Lightbox exposing (main)

-- TODO: Display quick-select thumbnails below the image if there's enough room?
-- TODO: The first image in a gallery is not aligned properly
-- TODO: Indicate which images are NSFW

import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
import Array
import Task
import List
import Browser
import Browser.Events as EV
import Browser.Dom as DOM
import Json.Decode as JD
import Lib.Html exposing (..)


main : Program () (Maybe Model) Msg
main = Browser.element
  { init   = always (Nothing, Cmd.none)
  , view   = view
  , update = update
  , subscriptions = \m ->
      if m == Nothing
      then open Open
      else Sub.batch
        [ EV.onResize Resize
        , EV.onKeyDown <| JD.map Keydown <| JD.field "key" JD.string
        , preloaded Preloaded
        ]
  }

port close : Bool -> Cmd msg
port open : (Model -> msg) -> Sub msg
port preload : String -> Cmd msg
port preloaded : (String -> msg) -> Sub msg

type alias Release =
  { id     : Int
  , title  : String
  , lang   : List String
  , plat   : List String
  }

type alias Image =
  { thumb  : String
  , full   : String
  , width  : Int
  , height : Int
  , load   : Bool
  , rel    : Maybe Release
  }

type alias Model =
  { images  : Array.Array Image
  , current : Int
  , width   : Int
  , height  : Int
  }

type Msg
  = Noop
  | Next
  | Prev
  | Open Model
  | Close
  | Resize Int Int
  | Viewport DOM.Viewport
  | Preloaded String
  | Keydown String


setPreload : Model -> Cmd Msg
setPreload model =
  let cmd n =
        case Array.get (model.current+n) model.images of
          Nothing -> Cmd.none
          Just i -> if i.load then Cmd.none else preload i.full
  in if cmd 0 /= Cmd.none then cmd 0 else Cmd.batch [cmd -1, cmd 1]


update_ : Msg -> Model -> (Model, Cmd Msg)
update_ msg model =
  let move n = 
        case Array.get (model.current+n) model.images of
          Nothing -> (model, Cmd.none)
          Just i -> let m = { model | current = model.current+n } in (m, setPreload m)
  in
  case msg of
    Noop                 -> (model, Cmd.none)
    Next                 -> move 1
    Prev                 -> move -1
    Keydown "ArrowLeft"  -> move -1
    Keydown "ArrowRight" -> move 1
    Keydown _            -> (model, Cmd.none)
    Resize width height  -> ({ model | width = width,                  height = height                  }, Cmd.none)
    Viewport v           -> ({ model | width = round v.viewport.width, height = round v.viewport.height }, Cmd.none)
    Preloaded url ->
      let m = { model | images = Array.map (\img -> if img.full == url then { img | load = True } else img) model.images }
      in (m, setPreload m)
    _ -> (model, Cmd.none)


update : Msg -> Maybe Model -> (Maybe Model, Cmd Msg)
update msg model =
  case (msg, model) of
    (Open m          , _) -> ( Just m
                             , Cmd.batch [setPreload m, Task.perform Viewport DOM.getViewport]
                             )
    (Close           , _) -> (Nothing, close True)
    (Keydown "Escape", _) -> (Nothing, close True)
    (_               , Just m) -> let (newm, cmd) = update_ msg m in (Just newm, cmd)
    _ -> (model, Cmd.none)



view_ : Model -> Html Msg
view_ model =
  let
    -- 'onClick' with stopPropagation and preventDefault
    onClickN action = custom "click" (JD.succeed { message = action, stopPropagation = True, preventDefault = True})
    -- 'onClick' with stopPropagation
    onClickP action = custom "click" (JD.succeed { message = action, stopPropagation = True, preventDefault = False})

    -- Maximum image dimensions
    awidth  = toFloat model.width * 0.84
    aheight = toFloat model.height - 80

    full_img action position i =
      -- Scale image down to fit inside awidth/aheight
      let swidth  = awidth  / toFloat i.width
          sheight = aheight / toFloat i.height
          scale   = Basics.min 1 <| if swidth < sheight then swidth else sheight
          iwidth  = round <| scale * toFloat i.width
          iheight = round <| scale * toFloat i.height
          cwidth  = style "width"  <| String.fromInt iwidth  ++ "px"
          cheight = style "height" <| String.fromInt iheight ++ "px"
          imgsrc  = if i.load then i.full else i.thumb
      in
      a [ href "#", onClickN action, cheight
        , class <| "lightbox__image lightbox__image-" ++ position ]
        [ img [ class "lightbox__img", src imgsrc, cwidth, cheight ] [] ]

    full offset action position =
      case Array.get (model.current + offset) model.images of
        Nothing -> text ""
        Just i -> full_img action position i

    meta img = div [ class "lightbox__meta", onClickP Noop ] <|
      [ a [ href img.full, class "lightbox__dims" ] [ text <| String.fromInt img.width ++ "x" ++ String.fromInt img.height ]
      ] ++ relMeta img.rel

    relMeta r = case r of
      Nothing  -> []
      Just rel ->
           (List.map iconPlatform rel.plat)
        ++ (List.map iconLanguage rel.lang)
        ++ [ a [ href ("/r" ++ String.fromInt rel.id) ] [ text rel.title ] ]

    container img = div [ class "lightbox", onClick Close ]
      [ a [ href "#", onClickN Close, class "lightbox__close" ] []
      , full -1 Prev  "left"
      , full  0 Close "current"
      , full  1 Next  "right"
      , meta img
      ]

  in case Array.get model.current model.images of
    Just img -> container img
    Nothing  -> text ""


view : (Maybe Model) -> Html Msg
view m = case m of
  Just mod -> view_ mod
  Nothing  -> text ""