Advsearch: Add release date filter

This required some changes to the query model and encoded form, since it
doing this with only <= and => operators is too limited.

I changed the compact encoding of strings to only encode the length in
the type field for specific (common) lengths and fallback to an
end-of-string character for everything else. This leaves room for more
custom types.

5 files changed, 145 insertions, 14 deletions

diff --git a/elm/AdvSearch/Fields.elm b/elm/AdvSearch/Fields.elm
index 64f9399a..6c4e3b29 100644
--- a/elm/AdvSearch/Fields.elm
+++ b/elm/AdvSearch/Fields.elm
@@ -9,6 +9,7 @@ import Lib.DropDown as DD
 import Lib.Api as Api
 import AdvSearch.Set as AS
 import AdvSearch.Producers as AP
+import AdvSearch.RDate as AR
 import AdvSearch.Query exposing (..)
 
 
@@ -187,6 +188,7 @@ type FieldModel
   | FMPlatform (AS.Model String)
   | FMLength   (AS.Model Int)
   | FMDeveloper AP.Model
+  | FMRDate    AR.Model
 
 type FieldMsg
   = FSCustom   () -- Not actually used at the moment
@@ -196,6 +198,7 @@ type FieldMsg
   | FSPlatform (AS.Msg String)
   | FSLength   (AS.Msg Int)
   | FSDeveloper AP.Msg
+  | FSRDate    AR.Msg
   | FToggle Bool
   | FDel       -- intercepted in nestUpdate
   | FMoveSub   -- intercepted in nestUpdate
@@ -237,10 +240,12 @@ fields =
   , f V "Length"            (Just 4)  FMLength    AS.init               AS.lengthFromQuery
   , f V "Developer"         Nothing   FMDeveloper AP.init               AP.devFromQuery
   , f V "Release"           Nothing   FMNest      (nestInit NRel R [])  (nestFromQuery NRel V)
+  , f V "Release date"      Nothing   FMRDate     AR.init               AR.fromQuery
 
   , f R "Language"          (Just 1)  FMLang      AS.init               AS.langFromQuery
   , f R "Platform"          (Just 2)  FMPlatform  AS.init               AS.platformFromQuery
   , f R "Developer"         Nothing   FMDeveloper AP.init               AP.devFromQuery
+  , f R "Release date"      Nothing   FMRDate     AR.init               AR.fromQuery
   ]
 
 
@@ -274,6 +279,7 @@ fieldUpdate dat msg_ (num, dd, model) =
       (FSPlatform msg, FMPlatform m) -> maps FMPlatform (AS.update msg m)
       (FSLength msg,   FMLength m)   -> maps FMLength   (AS.update msg m)
       (FSDeveloper msg,FMDeveloper m)-> mapf FMDeveloper FSDeveloper (AP.update dat msg m)
+      (FSRDate msg,    FMRDate m)    -> maps FMRDate    (AR.update msg m)
       (FToggle b, _) -> (dat, (num, DD.toggle dd b, model), Cmd.none)
       _ -> noop
 
@@ -304,6 +310,7 @@ fieldView dat (_, dd, model) =
       FMPlatform m -> vs FSPlatform (AS.platformView m)
       FMLength m   -> vs FSLength   (AS.lengthView m)
       FMDeveloper m-> vs FSDeveloper(AP.devView dat m)
+      FMRDate m    -> vs FSRDate    (AR.view m)
 
 
 fieldToQuery : Field -> Maybe Query
@@ -316,6 +323,7 @@ fieldToQuery (_, _, model) =
     FMPlatform m -> AS.toQuery (QStr 4) m
     FMLength m   -> AS.toQuery (QInt 5) m
     FMDeveloper m-> AP.toQuery (QInt 6) m
+    FMRDate m    -> AR.toQuery m
 
 
 fieldCreate : Int -> (Data,FieldModel) -> (Data,Field)
diff --git a/elm/AdvSearch/Query.elm b/elm/AdvSearch/Query.elm
index 686580f1..acbd3e77 100644
--- a/elm/AdvSearch/Query.elm
+++ b/elm/AdvSearch/Query.elm
@@ -9,7 +9,7 @@ import Gen.Api as GApi
 -- Used only as an intermediate format to help with encoding/decoding.
 -- Corresponds to the compact JSON encoding, i.e. with field names and VNDBIDs encoded and integers.
 type QType = V | R
-type Op = Eq | Ne | Ge | Le
+type Op = Eq | Ne | Ge | Gt | Le | Lt
 type Query
   = QAnd (List Query)
   | QOr (List Query)
@@ -24,7 +24,9 @@ encodeOp o = JE.string <|
     Eq -> "="
     Ne -> "!="
     Ge -> ">="
+    Gt -> ">"
     Le -> "<="
+    Lt -> "<"
 
 encodeQuery : Query -> JE.Value
 encodeQuery q =
@@ -53,7 +55,9 @@ decodeOp = JD.string |> JD.andThen (\s ->
     "="  -> JD.succeed Eq
     "!=" -> JD.succeed Ne
     ">=" -> JD.succeed Ge
+    ">"  -> JD.succeed Gt
     "<=" -> JD.succeed Le
+    "<"  -> JD.succeed Lt
     _    -> JD.fail "Invalid operator")
 
 decodeQuery : JD.Decoder Query
@@ -107,9 +111,17 @@ encQuery query =
           Eq -> 0
           Ne -> 1
           Ge -> 2
-          Le -> 3
-      encTypeOp o t = Maybe.withDefault "" <| encInt <| encOp o + 4*t
-      encStrField n o v = let s = encStr v in fint n ++ encTypeOp o (String.length s + 9) ++ s
+          Gt -> 3
+          Le -> 4
+          Lt -> 5
+      encTypeOp o t = Maybe.withDefault "" <| encInt <| encOp o + 8*t
+      encStrField n o v =
+        let s = encStr v
+            f l = fint n ++ encTypeOp o l ++ s
+        in case String.length s of
+                  2 -> f 2
+                  3 -> f 3
+                  l -> f 4 ++ "-"
   in case query of
       QAnd l -> lst 0 l
       QOr l  -> lst 1 l
@@ -121,6 +133,16 @@ encQuery query =
       QQuery n o q -> fint n ++ encTypeOp o 1 ++ encQuery q
 
 
+showOp : Op -> String
+showOp op =
+  case op of
+    Eq -> "="
+    Ne -> "≠"
+    Le -> "≤"
+    Lt -> "<"
+    Ge -> "≥"
+    Gt -> ">"
+
 
 -- Global data that's passed around for Fields
 -- (defined here because everything imports this module)
diff --git a/elm/AdvSearch/RDate.elm b/elm/AdvSearch/RDate.elm
new file mode 100644
index 00000000..8c2eaf9d
--- /dev/null
+++ b/elm/AdvSearch/RDate.elm
@@ -0,0 +1,97 @@
+module AdvSearch.RDate exposing (..)
+
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Lib.Html exposing (..)
+import Lib.RDate as R
+import AdvSearch.Query exposing (..)
+
+
+type alias Model =
+  { op    : Op
+  , fuzzy : Bool
+  , date  : R.RDate
+  }
+
+
+type Msg
+  = MOp Op Bool
+  | Fuzzy Bool
+  | Date R.RDate
+
+
+update : Msg -> Model -> Model
+update msg model =
+  case msg of
+    MOp o _ -> { model | op = o }
+    Fuzzy f -> { model | fuzzy = f }
+    Date d  -> { model | date = d }
+
+
+init : Data -> (Data, Model)
+init dat = (dat,
+  { op    = Le
+  , fuzzy = True
+  , date  = 1
+  })
+
+
+toQuery : Model -> Maybe Query
+toQuery model = Just <|
+  let f o date = QInt 7 o date
+      e = R.expand model.date
+      ystart = R.compact { y=e.y, m=  1, d= 1 }
+      mstart = R.compact { y=e.y, m=e.m, d= 1 }
+  in
+  if not model.fuzzy || e.y == 0 || e.y == 9999 then f model.op model.date else
+  case (model.op, e.m, e.d) of
+    -- Fuzzy (in)equality turns into a date range
+    (Eq, 99, 99) -> QAnd [ f Ge ystart, f Le model.date ]
+    (Eq,  _, 99) -> QAnd [ f Ge mstart, f Le model.date ]
+    (Ne, 99, 99) -> QOr  [ f Lt ystart, f Gt model.date ]
+    (Ne,  _, 99) -> QOr  [ f Lt mstart, f Gt model.date ]
+    -- Fuzzy Ge and Lt just need the date adjusted to the correct boundary
+    (Ge, 99, 99) -> f Ge ystart
+    (Ge,  _, 99) -> f Ge mstart
+    (Lt, 99, 99) -> f Lt ystart
+    (Lt,  _, 99) -> f Lt mstart
+    _ -> f model.op model.date
+
+
+fromQuery : Data -> Query -> Maybe (Data, Model)
+fromQuery dat q =
+  let m op fuzzy date = Just (dat, { op = op, fuzzy = fuzzy, date = date })
+      fuzzyNeq op start end =
+        let se = R.expand start
+            ee = R.expand end
+        in  if se.y == ee.y && (ee.m < 99 || se.m == 1) && se.d == 1 && ee.d == 99 then m op True end else Nothing
+      canFuzzy o e = e.y == 0 || e.y == 9999 || e.d /= 99 || o == Gt || o == Le
+  in
+  case q of
+    QAnd [QInt 7 Ge start, QInt 7 Le end] -> fuzzyNeq Eq start end
+    QOr  [QInt 7 Lt start, QInt 7 Gt end] -> fuzzyNeq Ne start end
+    QInt 7 o v -> m o (canFuzzy o (R.expand v)) v
+    _ -> Nothing
+
+
+view : Model -> (Html Msg, () -> List (Html Msg))
+view model =
+  ( text <| showOp model.op ++ " " ++ R.format (R.expand model.date)
+  , \() ->
+    [ div [ class "advheader", style "width" "290px" ]
+      [ h3 [] [ text "Release date" ]
+      , div [ class "opts" ]
+        [ div [ class "opselect" ] <|
+          List.map (\op ->
+            if model.op == op then b [] [ text (showOp op) ] else a [ href "#", onClickD (MOp op True) ] [ text (showOp op) ]
+          ) [Eq, Ne, Ge, Gt, Le, Lt]
+        , linkRadio model.fuzzy Fuzzy [ span [ title
+            <| "Without fuzzy matching, partial dates will always match after the last date of the chosen time period, "
+            ++ "e.g. \"< 2010-10\" would also match anything released in 2010-10 and \"= 2010-10\" would only match releases for which we don't know the exact date."
+            ++ "\n\nFuzzy match will adjust the query to do what you mean."
+          ] [ text "fuzzy" ] ]
+        ]
+      ]
+    , R.view model.date True True Date
+    ]
+  )
diff --git a/elm/Lib/RDate.elm b/elm/Lib/RDate.elm
index 67888114..1eeac80d 100644
--- a/elm/Lib/RDate.elm
+++ b/elm/Lib/RDate.elm
@@ -1,8 +1,9 @@
 -- Utility module and UI widget for handling release dates.
 --
--- Release dates are integers with the following format: 0 or yyyymmdd
+-- Release dates are integers with the following format: 0, 1 or yyyymmdd
 -- Special values
---   0        -> unknown
+--          0 -> unknown
+--          1 -> "today" (only used as filter)
 --   99999999 -> TBA
 --   yyyy9999 -> year known, month & day unknown
 --   yyyymm99 -> year & month known, day unknown
@@ -47,15 +48,17 @@ fromDate d =
 
 normalize : RDateComp -> RDateComp
 normalize r =
-       if r.y == 0    then { y = 0,    m = 0,  d = 0  }
+       if r.y == 0    then { y = 0,    m = 0,  d = clamp 0 1 r.y }
   else if r.y == 9999 then { y = 9999, m = 99, d = 99 }
-  else if r.m == 99   then { y = r.y,  m = 99, d = 99 }
+  else if r.m == 0 || r.m == 99 then { y = r.y,  m = 99, d = 99 }
+  else if r.d == 0 then { r | d = 99 }
   else r
 
 
 format : RDateComp -> String
 format date =
   case (date.y, date.m, date.d) of
+    (   0,  0,  1) -> "today"
     (   0,  _,  _) -> "unknown"
     (9999,  _,  _) -> "TBA"
     (   y, 99, 99) -> String.fromInt y
@@ -76,13 +79,14 @@ display today d =
 -- longer valid results in an invalid RDate. It also causes the "-day-" option
 -- to be selected (which is good), so I don't expect that many people will try
 -- to submit the form without changing it.
-view : RDate -> Bool -> (RDate -> msg) -> Html msg
-view ro permitUnknown msg =
+view : RDate -> Bool -> Bool -> (RDate -> msg) -> Html msg
+view ro permitUnknown permitToday msg =
   let r = expand ro
       range from to f = List.range from to |> List.map (\n -> (f n |> normalize |> compact, String.fromInt n))
-      yl = (if permitUnknown then [(0, "Unknown")] else [])
-           ++ [(99999999, "TBA")]
-           ++ List.reverse (range 1980 (GT.curYear + 5) (\n -> {r|y=n}))
+      yl = (if permitToday   then [(1, "Today"  )] else [])
+        ++ (if permitUnknown then [(0, "Unknown")] else [])
+        ++ [(99999999, "TBA")]
+        ++ List.reverse (range 1980 (GT.curYear + 5) (\n -> {r|y=n}))
       ml = ({r|m=99} |> normalize |> compact, "- month -") :: range 1 12 (\n -> {r|m=n})
       maxDay = Date.fromCalendarDate r.y (Date.numberToMonth r.m) 1 |> Date.add Date.Months 1 |> Date.add Date.Days -1 |> Date.day
       dl = ({r|d=99} |> normalize |> compact, "- day -") :: range 1 maxDay (\n -> {r|d=n})
diff --git a/elm/ReleaseEdit.elm b/elm/ReleaseEdit.elm
index b62678c9..9eef138a 100644
--- a/elm/ReleaseEdit.elm
+++ b/elm/ReleaseEdit.elm
@@ -345,7 +345,7 @@ viewGen model =
   , formField "" [ label [] [ inputCheck "" model.freeware Freeware, text " Freeware (i.e. available at no cost)" ] ]
   , if model.patch then text "" else
     formField "" [ label [] [ inputCheck "" model.doujin   Doujin  , text " Doujin (self-published, not by a company)" ] ]
-  , formField "Release date" [ D.view model.released False Released, text " Leave month or day blank if they are unknown." ]
+  , formField "Release date" [ D.view model.released False False Released, text " Leave month or day blank if they are unknown." ]
 
   , tr [ class "newpart" ] [ td [ colspan 2 ] [ text "Format" ] ]
   , formField "Language(s)"