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 ""
|