diff options
Diffstat (limited to 'elm/AdvSearch/Fields.elm')
-rw-r--r-- | elm/AdvSearch/Fields.elm | 784 |
1 files changed, 784 insertions, 0 deletions
diff --git a/elm/AdvSearch/Fields.elm b/elm/AdvSearch/Fields.elm new file mode 100644 index 00000000..2ec6e205 --- /dev/null +++ b/elm/AdvSearch/Fields.elm @@ -0,0 +1,784 @@ +module AdvSearch.Fields exposing (..) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Array +import Set +import Lib.Util exposing (..) +import Lib.Html exposing (..) +import Lib.DropDown as DD +import Lib.Api as Api +import Lib.Autocomplete as A +import AdvSearch.Anime as AA +import AdvSearch.Set as AS +import AdvSearch.Producers as AP +import AdvSearch.Staff as AT +import AdvSearch.Tags as AG +import AdvSearch.Traits as AI +import AdvSearch.RDate as AD +import AdvSearch.Range as AR +import AdvSearch.Resolution as AE +import AdvSearch.Engine as AEng +import AdvSearch.DRM as ADRM +import AdvSearch.Birthday as AB +import AdvSearch.Lib exposing (..) +import Gen.ExtLinks as GEL + + +-- "Nested" fields are a container for other fields. +-- The code for nested fields is tightly coupled with the generic 'Field' abstraction below. + +type alias NestModel = + { ptype : QType -- type of the parent field + , qtype : QType -- type of the child fields + , fields : List Field + , and : Bool + , andDd : DD.Config FieldMsg + , addDd : DD.Config FieldMsg + , addtype : List QType + , neg : Bool -- only if ptype /= qtype + } + + +type NestMsg + = NAndToggle Bool + | NAnd Bool Bool + | NAddToggle Bool + | NAdd Int + | NAddType (List QType) + | NField Int FieldMsg + | NNeg Bool Bool + + +nestInit : Bool -> QType -> QType -> List Field -> Data -> (Data, NestModel) +nestInit and ptype qtype list dat = + ( { dat | objid = dat.objid+2 } + , { ptype = ptype + , qtype = qtype + , fields = list + , and = and + , andDd = DD.init ("xsearch_field"++String.fromInt (dat.objid+0)) (FSNest << NAndToggle) + , addDd = DD.init ("xsearch_field"++String.fromInt (dat.objid+1)) (FSNest << NAddToggle) + , addtype = [qtype] + , neg = False + } + ) + + +nestUpdate : Data -> NestMsg -> NestModel -> (Data, NestModel, Cmd NestMsg) +nestUpdate dat msg model = + case msg of + NAndToggle b -> (dat, { model | andDd = DD.toggle model.andDd b, addtype = [model.qtype] }, Cmd.none) + NAnd b _ -> (dat, { model | and = b, andDd = DD.toggle model.andDd False }, Cmd.none) + NAddToggle b -> (dat, { model | addDd = DD.toggle model.addDd b, addtype = [model.qtype] }, Cmd.none) + NAdd n -> + let addPar lst (ndat,f) = + case lst of + (a::b::xs) -> + -- Don't add the child field if it's an And/Or, the parent field covers that already. + let nf = case f of + (_,_,FMNest m) -> if m.ptype == m.qtype then [] else [f] + _ -> [f] + in addPar (b::xs) (nestInit True b a nf ndat |> Tuple.mapSecond FMNest |> fieldCreate -1) + _ -> (ndat,f) + (ndat2,f2) = addPar model.addtype (fieldInit n dat) + nestMsg lst i = + case lst of + (a::xs) -> NField i (FSNest (nestMsg xs 0)) + _ -> NField i (FToggle True) + in (ndat2, { model | addDd = DD.toggle model.addDd False, addtype = [model.qtype], fields = model.fields ++ [f2] } + , selfCmd (nestMsg (List.drop 1 model.addtype) (List.length model.fields))) + NAddType t -> (dat, { model | addtype = t }, Cmd.none) + NField n FDel -> (dat, { model | fields = delidx n model.fields }, Cmd.none) + NField n FMoveSub -> + let subfields = List.drop n model.fields |> List.take 1 |> List.map (\(fid,fdd,fm) -> (fid, DD.toggle fdd False, fm)) + (ndat,subm) = nestInit (not model.and) model.qtype model.qtype subfields dat + (ndat2,subf) = fieldCreate -1 (ndat, FMNest subm) + in (ndat2, { model | fields = modidx n (always subf) model.fields }, Cmd.none) + NField n m -> + case List.head (List.drop n model.fields) of + Nothing -> (dat, model, Cmd.none) + Just f -> + let (ndat, nf, nc) = fieldUpdate dat m f + in (ndat, { model | fields = modidx n (always nf) model.fields }, Cmd.map (NField n) nc) + NNeg b _ -> (dat, { model | neg = b }, Cmd.none) + + +nestToQuery : Data -> NestModel -> Maybe Query +nestToQuery dat model = + let op = if model.neg then Ne else Eq + com = if model.and then QAnd else QOr + wrap f = + case List.filterMap (fieldToQuery dat) model.fields of + [] -> Nothing + [x] -> Just (f x) + xs -> Just (f (com xs)) + in case (model.ptype, model.qtype) of + (V, R) -> wrap (QQuery 50 op) + (V, C) -> wrap (QQuery 51 op) + (V, S) -> wrap (QQuery 52 op) + (V, P) -> wrap (QQuery 55 op) + (C, S) -> wrap (QQuery 52 op) + (C, V) -> wrap (QQuery 53 op) + (R, V) -> wrap (QQuery 53 op) + (R, P) -> wrap (QQuery 55 op) + _ -> wrap identity + + +nestFromQuery : QType -> QType -> Data -> Query -> Maybe (Data, NestModel) +nestFromQuery ptype qtype dat q = + let init and l = + let (ndat,fl) = List.foldr (\f (d,a) -> let (nd,fm) = fieldFromQuery qtype d f in (nd,(fm::a))) (dat,[]) l + in nestInit and ptype qtype fl ndat + + initSub op val = if op /= Eq && op /= Ne then Nothing else Just <| + let (ndat,f) = fieldFromQuery qtype dat val + (ndat2,m) = nestInit True ptype qtype [f] ndat + -- If there is only a single nested query and it's an and/or nest, merge it into this node. + m2 = case m.fields of + [(_,_,FMNest cm)] -> if cm.ptype == cm.qtype then { m | fields = cm.fields, and = cm.and } else m + _ -> m + in (ndat2, { m2 | neg = op == Ne }) + + in case (ptype, qtype, q) of + (V, R, QQuery 50 op r) -> initSub op r + (V, C, QQuery 51 op r) -> initSub op r + (V, S, QQuery 52 op r) -> initSub op r + (V, P, QQuery 55 op r) -> initSub op r + (C, S, QQuery 52 op r) -> initSub op r + (C, V, QQuery 53 op r) -> initSub op r + (R, V, QQuery 53 op r) -> initSub op r + (R, P, QQuery 55 op r) -> initSub op r + (_, _, QAnd l) -> if ptype == qtype then Just (init True l) else Nothing + (_, _, QOr l) -> if ptype == qtype then Just (init False l) else Nothing + _ -> Nothing + + +nestView : Data -> DD.Config FieldMsg -> NestModel -> Html FieldMsg +nestView dat dd model = + let + isNest (_,_,f) = + case f of + FMNest _ -> True + _ -> False + hasNest = List.any isNest model.fields + filterDat = + { dat + | level = if model.ptype /= model.qtype then 1 else dat.level+1 + , parentTypes = if model.ptype /= model.qtype then Set.insert (showQType model.ptype) dat.parentTypes else dat.parentTypes + } + filters = List.indexedMap (\i f -> + Html.map (FSNest << NField i) <| fieldView filterDat f + ) model.fields + + add = + let parents = Set.union filterDat.parentTypes <| Set.fromList <| List.map showQType <| List.drop 1 model.addtype + lst = Array.toIndexedList fields |> List.filter (\(_,f) -> + Just f.ptype == List.head model.addtype + && f.title /= "" + && (dat.uid /= Nothing || f.title /= "My Labels") + && (dat.uid /= Nothing || f.title /= "My List") + && (f.title /= "Name" || not (Set.isEmpty parents)) + && not (f.title == "Role" && (List.head (List.drop 1 model.addtype)) == Just C) -- No "role" filter for character seiyuu (the seiyuu role is implied, after all) + && not (Set.member (showQType f.qtype) parents)) + showT par t = + case (par,t) of + (_,V) -> "VN" + (_,R) -> "Release" + (_,C) -> "Character" + (C,S) -> "VA" + (_,S) -> "Staff" + (V,P) -> "Developer" + (_,P) -> "Producer" + breads pre par l = + case l of + [] -> [] + [x] -> [ strong [] [ text (showT par x) ] ] + (x::xs) -> a [ href "#", onClickD (FSNest (NAddType (x::pre))) ] [ text (showT par x) ] :: text " » " :: breads (x::pre) x xs + in + div [ class "elm_dd_input elm_dd_noarrow short" ] + [ DD.view model.addDd Api.Normal (text "+") <| \() -> + [ div [ class "advheader", style "min-width" "200px" ] + [ h3 [] [ text "Add filter" ] + , if List.length model.addtype <= 1 then text "" else + div [] <| breads [] model.qtype (List.reverse model.addtype) + ] + , ul (if List.length lst > 6 then [ style "columns" "2" ] else []) <| + List.map (\(n,f) -> + li [] [ a [ href "#", onClickD (FSNest <| if f.qtype /= f.ptype then NAddType (f.qtype :: model.addtype) else NAdd n)] [ text f.title ] ] + ) lst + ] + ] + + andcont () = [ ul [] + [ li [] [ linkRadio ( model.and) (FSNest << NAnd True ) [ text "And: All filters must match" ] ] + , li [] [ linkRadio (not model.and) (FSNest << NAnd False) [ text "Or: At least one filter must match" ] ] + ] ] + + andlbl = text <| if model.and then "And" else "Or" + + and = div [ class "elm_dd_input short" ] [ DD.view model.andDd Api.Normal andlbl andcont ] + + negcont () = + let (a,b) = + case (model.ptype, model.qtype) of + (_, C) -> ("Has a character that matches these filters", "Does not have a character that matches these filters") + (_, R) -> ("Has a release that matches these filters", "Does not have a release that matches these filters") + (_, V) -> ("Linked to a visual novel that matches these filters", "Not linked to a visual novel that matches these filters") + (V, S) -> ("Has staff that matches these filters", "Does not have staff that matches these filters") + (V, P) -> ("Has a developer that matches these filters", "Does not have a developer that matches these filters") + (C, S) -> ("Has a voice actor that matches these filters", "Does not have a voice actor that matches these filters") + (R, P) -> ("Has a producer that matches these filters", "Does not have a producer that matches these filters") + _ -> ("","") + in [ ul [] + [ li [] [ linkRadio (not model.neg) (FSNest << NNeg False) [ text a ] ] + , li [] [ linkRadio ( model.neg) (FSNest << NNeg True ) [ text b ] ] + ] ] + + neglbl = text <| (if model.neg then "¬" else "") ++ + case (model.ptype, model.qtype) of + (_, C) -> "Char" + (_, R) -> "Rel" + (_, V) -> "VN" + (V, S) -> "Staff" + (V, P) -> "Developer" + (R, P) -> "Producer" + (C, S) -> "VA" + _ -> "" + + ourdd = + if model.qtype == model.ptype + then fieldViewDd dat dd andlbl andcont + else fieldViewDd dat dd neglbl negcont + + initialdd = if model.ptype == model.qtype || List.length model.fields == 1 then [ ourdd ] else [ ourdd, and ] + + in + if hasNest + then table [ class "advnest" ] <| List.indexedMap (\i f -> tr [] + [ td [] <| if i == 0 then initialdd else [] + , td [ class (if i == 0 then "start" else "mid") ] [ div [] [], span [] [] ] + , td [] [ f ] + ]) filters + ++ [ tr [] + [ td [] [] + , td [ class "end" ] [ div [] [], span [] [] ] + , td [] [ add ] + ] + ] + else table [ class "advrow" ] [ tr [] + [ td [] (initialdd ++ [small [] [ text " → " ]]) + , td [] (filters ++ [add]) ] ] + + + + + +-- Generic field abstraction. +-- (this is where typeclasses would have been *awesome*) +-- +-- The following functions and definitions are only intended to provide field +-- listings and function dispatchers, if the implementation of anything in here +-- is longer than a single line, it should get its own definition near where +-- the rest of that field is defined. + +type alias Field = (Int, DD.Config FieldMsg, FieldModel) -- The Int is the index into 'fields' + +type alias ListModel = + { val : Int + , lst : List (Query, String) + } + +type FieldModel + = FMCustom Query -- A read-only placeholder for Query values that failed to parse into a Field + | FMNest NestModel + | FMList ListModel + | FMLang AS.LangModel + | FMRPlatform (AS.Model String) + | FMVPlatform (AS.Model String) + | FMLength (AS.Model Int) + | FMDevStatus (AS.Model Int) + | FMRole (AS.Model String) + | FMBlood (AS.Model String) + | FMSex (AS.SexModel) + | FMGender (AS.Model String) + | FMMedium (AS.Model String) + | FMVoiced (AS.Model Int) + | FMAniEro (AS.Model Int) + | FMAniStory (AS.Model Int) + | FMRType (AS.Model String) + | FMLabel (AS.Model Int) + | FMRList (AS.Model Int) + | FMSRole (AS.Model String) + | FMPType (AS.Model String) + | FMRExtLinks (AS.Model String) + | FMSExtLinks (AS.Model String) + | FMHeight (AR.Model Int) + | FMWeight (AR.Model Int) + | FMBust (AR.Model Int) + | FMWaist (AR.Model Int) + | FMHips (AR.Model Int) + | FMCup (AR.Model String) + | FMAge (AR.Model Int) + | FMPopularity (AR.Model Int) + | FMRating (AR.Model Int) + | FMVotecount (AR.Model Int) + | FMMinAge (AR.Model Int) + | FMProdId AP.Model + | FMProducer AP.Model + | FMDeveloper AP.Model + | FMStaff AT.Model + | FMAnime AA.Model + | FMRDate AD.Model + | FMResolution AE.Model + | FMEngine AEng.Model + | FMDRMType ADRM.Model + | FMTag AG.Model + | FMTrait AI.Model + | FMBirthday AB.Model + +type FieldMsg + = FSCustom () -- Not actually used at the moment + | FSNest NestMsg + | FSList Int + | FSLang (AS.Msg String) + | FSRPlatform (AS.Msg String) + | FSVPlatform (AS.Msg String) + | FSLength (AS.Msg Int) + | FSDevStatus (AS.Msg Int) + | FSRole (AS.Msg String) + | FSBlood (AS.Msg String) + | FSSex AS.SexMsg + | FSGender (AS.Msg String) + | FSMedium (AS.Msg String) + | FSVoiced (AS.Msg Int) + | FSAniEro (AS.Msg Int) + | FSAniStory (AS.Msg Int) + | FSRType (AS.Msg String) + | FSLabel (AS.Msg Int) + | FSRList (AS.Msg Int) + | FSSRole (AS.Msg String) + | FSPType (AS.Msg String) + | FSRExtLinks (AS.Msg String) + | FSSExtLinks (AS.Msg String) + | FSHeight AR.Msg + | FSWeight AR.Msg + | FSBust AR.Msg + | FSWaist AR.Msg + | FSHips AR.Msg + | FSCup AR.Msg + | FSAge AR.Msg + | FSPopularity AR.Msg + | FSRating AR.Msg + | FSVotecount AR.Msg + | FSMinAge AR.Msg + | FSProdId AP.Msg + | FSProducer AP.Msg + | FSDeveloper AP.Msg + | FSStaff AT.Msg + | FSAnime AA.Msg + | FSRDate AD.Msg + | FSResolution AE.Msg + | FSEngine AEng.Msg + | FSDRMType ADRM.Msg + | FSTag AG.Msg + | FSTrait AI.Msg + | FSBirthday AB.Msg + | FToggle Bool + | FDel -- intercepted in nestUpdate + | FMoveSub -- intercepted in nestUpdate + | FMovePar + +type alias FieldDesc = + { qtype : QType + , ptype : QType + , title : String -- How it's listed in the field selection menu. + , quick : Int -- Whether it should be included in the default set of fields (>0) ("quick mode") and in which order. + , init : Data -> (Data, FieldModel) -- How to initialize an empty field + , fromQuery : Data -> Query -> Maybe (Data, FieldModel) -- How to initialize the field from a query + } + + +-- XXX: Should this be lazily initialized instead? May impact JS load time like this. +fields : Array.Array FieldDesc +fields = + let f qtype title quick wrap init fromq = + { qtype = qtype + , ptype = qtype + , title = title + , quick = quick + , init = \d -> (Tuple.mapSecond wrap (init d)) + , fromQuery = \d q -> Maybe.map (Tuple.mapSecond wrap) (fromq d q) + } + -- List type queries are fully defined here for convenience + l qtype title quick lst = + f qtype title quick FMList (\d -> (d, { val = 0, lst = lst })) + (\d q -> List.indexedMap (\i (k,v) -> (i,k,v)) lst |> List.filter (\(i,k,_) -> k == q) |> List.head |> Maybe.map (\(i,_,_) -> (d, { val = i, lst = lst }))) + -- Nested queries + n ptype qtype title = + { qtype = qtype + , ptype = ptype + , title = title + , quick = 0 + , init = nestInit True ptype qtype [] >> Tuple.mapSecond FMNest + , fromQuery = \d -> nestFromQuery ptype qtype d >> Maybe.map (Tuple.mapSecond FMNest) + } + in Array.fromList + -- IMPORTANT: This list is processed in reverse order when reading a Query + -- into Fields, so "catch all" fields must be listed first. In particular, + -- FMNest with qtype == ptype go before everything else. + + -- T TITLE QUICK WRAP INIT FROM_QUERY + [ n V V "And/Or" + , n V R "Release »" + , n V S "Staff »" + , n V C "Character »" + , n V P "Developer »" + , f V "Language" 1 FMLang (AS.langInit AS.LangVN) (AS.langFromQuery AS.LangVN) + , f V "Original language" 2 FMLang (AS.langInit AS.LangVNO) (AS.langFromQuery AS.LangVNO) + , f V "Platform" 3 FMVPlatform AS.init AS.platformFromQuery + , f V "Tags" 4 FMTag AG.init (AG.fromQuery -1 True False) + , f V "" -4 FMTag AG.init (AG.fromQuery 0 True False) + , f V "" -4 FMTag AG.init (AG.fromQuery 1 True False) + , f V "" -4 FMTag AG.init (AG.fromQuery 2 True False) + , f V "" -4 FMTag AG.init (AG.fromQuery 2 True True ) + , f V "" -4 FMTag AG.init (AG.fromQuery 0 False False) + , f V "" -4 FMTag AG.init (AG.fromQuery 1 False False) + , f V "" -4 FMTag AG.init (AG.fromQuery 2 False False) + , f V "" -4 FMTag AG.init (AG.fromQuery 2 False True ) + , f V "My Labels" 0 FMLabel AS.init AS.labelFromQuery + , l V "My List" 0 [(QInt 65 Eq 1, "On my list"), (QInt 65 Ne 1, "Not on my list")] + , f V "Length" 0 FMLength AS.init AS.lengthFromQuery + , f V "Development status" 0 FMDevStatus AS.init AS.devStatusFromQuery + , f V "Release date" 0 FMRDate AD.init AD.fromQuery + , f V "" -1 FMPopularity AR.popularityInit AR.popularityFromQuery + , f V "Rating" 0 FMRating AR.ratingInit AR.ratingFromQuery + , f V "Number of votes" 0 FMVotecount AR.votecountInit AR.votecountFromQuery + , f V "Anime" 0 FMAnime AA.init AA.fromQuery + , l V "Has description" 0 [(QInt 61 Eq 1, "Has description"), (QInt 61 Ne 1, "No description")] + , l V "Has anime" 0 [(QInt 62 Eq 1, "Has anime relation"), (QInt 62 Ne 1, "No anime relation")] + , l V "Has screenshot" 0 [(QInt 63 Eq 1, "Has screenshot(s)"), (QInt 63 Ne 1, "No screenshot(s)")] + , l V "Has review" 0 [(QInt 64 Eq 1, "Has review(s)"), (QInt 64 Ne 1, "No review(s)")] + -- Deprecated + , f V "" 0 FMDeveloper AP.init (AP.fromQuery 6) + + , n R R "And/Or" + , n R V "Visual Novel »" + , n R P "Producer »" + , f R "Language" 1 FMLang (AS.langInit AS.LangRel) (AS.langFromQuery AS.LangRel) + , f R "Platform" 2 FMRPlatform AS.init AS.platformFromQuery + , f R "Type" 3 FMRType AS.init AS.rtypeFromQuery + , l R "Patch" 0 [(QInt 61 Eq 1, "Patch to another release"),(QInt 61 Ne 1, "Standalone release")] + , l R "Freeware" 0 [(QInt 62 Eq 1, "Freeware"), (QInt 62 Ne 1, "Non-free")] + , l R "Erotic scenes" 0 [(QInt 66 Eq 1, "Has erotic scenes"), (QInt 66 Ne 1, "No erotic scenes")] + , l R "Uncensored" 0 [(QInt 64 Eq 1, "Uncensored (no mosaic)"), (QInt 64 Ne 1, "Censored (or no erotic content to censor)")] + , l R "Official" 0 [(QInt 65 Eq 1, "Official"), (QInt 65 Ne 1, "Unofficial")] + , f R "Release date" 0 FMRDate AD.init AD.fromQuery + , f R "Resolution" 0 FMResolution AE.init AE.fromQuery + , f R "Age rating" 0 FMMinAge AR.minageInit AR.minageFromQuery + , f R "Medium" 0 FMMedium AS.init AS.mediumFromQuery + , f R "Voiced" 0 FMVoiced AS.init AS.voicedFromQuery + , f R "Ero animation" 0 FMAniEro AS.init (AS.animatedFromQuery False) + , f R "Story animation" 0 FMAniStory AS.init (AS.animatedFromQuery True) + , f R "Engine" 0 FMEngine AEng.init AEng.fromQuery + , f R "DRM implementation" 0 FMDRMType ADRM.init ADRM.fromQuery + , f R "External links" 0 FMRExtLinks AS.init (AS.extlinkFromQuery 19) + , f R "My List" 0 FMRList AS.init AS.rlistFromQuery + -- Deprecated + , f R "" 0 FMDeveloper AP.init (AP.fromQuery 6) + , f R "" 0 FMProducer AP.init (AP.fromQuery 17) + + + , n C C "And/Or" + , n C S "Voice Actor »" + , n C V "Visual Novel »" + , f C "Role" 1 FMRole AS.init AS.roleFromQuery + , f C "Age" 0 FMAge AR.ageInit AR.ageFromQuery + , f C "Birthday" 0 FMBirthday AB.init AB.fromQuery + , f C "Sex" 2 FMSex (AS.sexInit False) (AS.sexFromQuery False) + , f C "" 0 FMSex (AS.sexInit True) (AS.sexFromQuery True) + , f C "Traits" 3 FMTrait AI.init (AI.fromQuery -1 True False) + , f C "" 0 FMTrait AI.init (AI.fromQuery 0 True False) + , f C "" 0 FMTrait AI.init (AI.fromQuery 1 True False) + , f C "" 0 FMTrait AI.init (AI.fromQuery 2 True False) + , f C "" 0 FMTrait AI.init (AI.fromQuery 2 True True) + , f C "" 0 FMTrait AI.init (AI.fromQuery 0 False False) + , f C "" 0 FMTrait AI.init (AI.fromQuery 1 False False) + , f C "" 0 FMTrait AI.init (AI.fromQuery 2 False False) + , f C "" 0 FMTrait AI.init (AI.fromQuery 2 False True) + , f C "Blood type" 0 FMBlood AS.init AS.bloodFromQuery + , f C "Height" 0 FMHeight AR.heightInit AR.heightFromQuery + , f C "Weight" 0 FMWeight AR.weightInit AR.weightFromQuery + , f C "Bust" 0 FMBust AR.bustInit AR.bustFromQuery + , f C "Waist" 0 FMWaist AR.waistInit AR.waistFromQuery + , f C "Hips" 0 FMHips AR.hipsInit AR.hipsFromQuery + , f C "Cup size" 0 FMCup AR.cupInit AR.cupFromQuery + + , n S S "And/Or" + , f S "Name" 0 FMStaff AT.init AT.fromQuery + , f S "Language" 1 FMLang (AS.langInit AS.LangStaff) (AS.langFromQuery AS.LangStaff) + , f S "Gender" 2 FMGender AS.init AS.genderFromQuery + , f S "Role" 3 FMSRole AS.init AS.sroleFromQuery + , f S "External links" 0 FMSExtLinks AS.init (AS.extlinkFromQuery 6) + + , n P P "And/Or" + , f P "Name" 0 FMProdId AP.init (AP.fromQuery 3) + , f P "Language" 1 FMLang (AS.langInit AS.LangProd) (AS.langFromQuery AS.LangProd) + , f P "Type" 2 FMPType AS.init AS.ptypeFromQuery + ] + + +fieldUpdate : Data -> FieldMsg -> Field -> (Data, Field, Cmd FieldMsg) +fieldUpdate dat msg_ (num, dd, model) = + let maps f m = (dat, (num, dd, f m), Cmd.none) -- Simple version: update function returns a Model + mapf fm fc (d,m,c) = (d, (num, dd, fm m), Cmd.map fc c) -- Full version: update function returns (Data, Model, Cmd) + mapc fm fc (d,m,c) = (d, (num, DD.toggle dd False, fm m), Cmd.map fc c) -- Full version that also closes the DD (Ugly hack...) + noop = (dat, (num, dd, model), Cmd.none) + + -- Called when opening a dropdown, can be used to focus an input element + focus = + case model of + FMTag m -> Cmd.map FSTag (A.refocus m.conf) + FMTrait m -> Cmd.map FSTrait (A.refocus m.conf) + FMProdId m -> Cmd.map FSProdId (A.refocus m.conf) + FMProducer m -> Cmd.map FSProducer (A.refocus m.conf) + FMDeveloper m -> Cmd.map FSDeveloper (A.refocus m.conf) + FMStaff m -> Cmd.map FSStaff (A.refocus m.conf) + FMAnime m -> Cmd.map FSAnime (A.refocus m.conf) + FMResolution m -> Cmd.map FSResolution (A.refocus m.conf) + FMEngine m -> Cmd.map FSEngine (A.refocus m.conf) + FMDRMType m -> Cmd.map FSDRMType (A.refocus m.conf) + _ -> Cmd.none + in case (msg_, model) of + -- Move to parent node is tricky, needs to be intercepted at this point so that we can access the parent NestModel. + (FSNest (NField parentNum (FSNest (NField fieldNum FMovePar))), FMNest grandModel) -> + case List.head <| List.drop parentNum grandModel.fields of + Just (_,_,FMNest parentModel) -> + let fieldField = List.drop fieldNum parentModel.fields |> List.take 1 + newFields = List.map (\(fid,fdd,fm) -> (fid, DD.toggle fdd False, fm)) fieldField + newParentModel = { parentModel | fields = delidx fieldNum parentModel.fields } + addGrandFields = List.take parentNum grandModel.fields ++ newFields ++ List.drop parentNum grandModel.fields + newGrandFields = + if List.isEmpty newParentModel.fields + then delidx (parentNum+1) addGrandFields + else modidx (parentNum+1) (\(pid,pdd,_) -> (pid,pdd,FMNest newParentModel)) addGrandFields + newGrandModel = { grandModel | fields = newGrandFields } + in (dat, (num,dd,FMNest newGrandModel), Cmd.none) + _ -> noop + + -- Move root node to sub; for child nodes this is handled in nestUpdate, but the root node must be handled separately + (FMoveSub, FMNest m) -> + let subfields = [(num,DD.toggle dd False,model)] + (ndat,subm) = nestInit True m.qtype m.qtype subfields dat + (ndat2,subf) = fieldCreate -1 (ndat, FMNest subm) + in (ndat2, subf, Cmd.none) + + (FSNest (NAnd a b), FMNest m) -> mapc FMNest FSNest (nestUpdate dat (NAnd a b) m) + (FSNest (NNeg a b), FMNest m) -> mapc FMNest FSNest (nestUpdate dat (NNeg a b) m) + (FSNest msg, FMNest m) -> mapf FMNest FSNest (nestUpdate dat msg m) + (FSList msg, FMList m) -> (dat, (num,DD.toggle dd False,FMList { m | val = msg }), Cmd.none) + (FSLang msg, FMLang m) -> maps FMLang (AS.langUpdate msg m) + (FSRPlatform msg,FMRPlatform m)-> maps FMRPlatform(AS.update msg m) + (FSVPlatform msg,FMVPlatform m)-> maps FMVPlatform(AS.update msg m) + (FSLength msg, FMLength m) -> maps FMLength (AS.update msg m) + (FSDevStatus msg,FMDevStatus m)-> maps FMDevStatus(AS.update msg m) + (FSRole msg, FMRole m) -> maps FMRole (AS.update msg m) + (FSBlood msg, FMBlood m) -> maps FMBlood (AS.update msg m) + (FSSex msg, FMSex m) -> maps FMSex (AS.sexUpdate msg m) + (FSGender msg, FMGender m) -> maps FMGender (AS.update msg m) + (FSMedium msg, FMMedium m) -> maps FMMedium (AS.update msg m) + (FSVoiced msg, FMVoiced m) -> maps FMVoiced (AS.update msg m) + (FSAniEro msg, FMAniEro m) -> maps FMAniEro (AS.update msg m) + (FSAniStory msg, FMAniStory m) -> maps FMAniStory (AS.update msg m) + (FSRType msg, FMRType m) -> maps FMRType (AS.update msg m) + (FSLabel msg, FMLabel m) -> maps FMLabel (AS.update msg m) + (FSRList msg, FMRList m) -> maps FMRList (AS.update msg m) + (FSSRole msg, FMSRole m) -> maps FMSRole (AS.update msg m) + (FSPType msg, FMPType m) -> maps FMPType (AS.update msg m) + (FSRExtLinks msg,FMRExtLinks m)-> maps FMRExtLinks (AS.update msg m) + (FSSExtLinks msg,FMSExtLinks m)-> maps FMSExtLinks (AS.update msg m) + (FSHeight msg, FMHeight m) -> maps FMHeight (AR.update msg m) + (FSWeight msg, FMWeight m) -> maps FMWeight (AR.update msg m) + (FSBust msg, FMBust m) -> maps FMBust (AR.update msg m) + (FSWaist msg, FMWaist m) -> maps FMWaist (AR.update msg m) + (FSHips msg, FMHips m) -> maps FMHips (AR.update msg m) + (FSCup msg, FMCup m) -> maps FMCup (AR.update msg m) + (FSAge msg, FMAge m) -> maps FMAge (AR.update msg m) + (FSPopularity msg,FMPopularity m)->maps FMPopularity (AR.update msg m) + (FSRating msg, FMRating m) -> maps FMRating (AR.update msg m) + (FSVotecount msg,FMVotecount m)-> maps FMVotecount (AR.update msg m) + (FSMinAge msg ,FMMinAge m) -> maps FMMinAge (AR.update msg m) + (FSProdId msg, FMProdId m) -> mapf FMProdId FSProdId (AP.update dat msg m) + (FSProducer msg, FMProducer m) -> mapf FMProducer FSProducer (AP.update dat msg m) + (FSDeveloper msg,FMDeveloper m)-> mapf FMDeveloper FSDeveloper (AP.update dat msg m) + (FSStaff msg, FMStaff m) -> mapf FMStaff FSStaff (AT.update dat msg m) + (FSAnime msg, FMAnime m) -> mapf FMAnime FSAnime (AA.update dat msg m) + (FSRDate msg, FMRDate m) -> maps FMRDate (AD.update msg m) + (FSResolution msg,FMResolution m)->mapf FMResolution FSResolution (AE.update dat msg m) + (FSEngine msg, FMEngine m) -> mapf FMEngine FSEngine (AEng.update dat msg m) + (FSDRMType msg, FMDRMType m) -> mapf FMDRMType FSDRMType (ADRM.update dat msg m) + (FSTag msg, FMTag m) -> mapf FMTag FSTag (AG.update dat msg m) + (FSTrait msg, FMTrait m) -> mapf FMTrait FSTrait (AI.update dat msg m) + (FSBirthday msg, FMBirthday m) -> maps FMBirthday (AB.update msg m) + (FToggle b, _) -> (dat, (num, DD.toggle dd b, model), if b then focus else Cmd.none) + _ -> noop + + +fieldViewDd : Data -> DD.Config FieldMsg -> Html FieldMsg -> (() -> List (Html FieldMsg)) -> Html FieldMsg +fieldViewDd dat dd lbl cont = + div [ class "elm_dd_input" ] + [ DD.view dd Api.Normal lbl <| \() -> + div [ class "advbut" ] + [ if dat.level == 0 + then small [ title "Can't delete the top-level filter" ] [ text "⊗" ] + else a [ href "#", onClickD FDel, title "Delete this filter" ] [ text "⊗" ] + , if dat.level <= 1 + then small [ title "Can't move this filter to parent branch" ] [ text "↰" ] + else a [ href "#", onClickD FMovePar, title "Move this filter to parent branch" ] [ text "↰" ] + , a [ href "#", onClickD FMoveSub, title "Create new branch for this filter" ] [ text "↳" ] + ] :: cont () + ] + +fieldView : Data -> Field -> Html FieldMsg +fieldView dat (_, dd, model) = + let f wrap (lbl,cont) = fieldViewDd dat dd (Html.map wrap lbl) <| \() -> List.map (Html.map wrap) (cont ()) + l m = ( span [ class "nowrap" ] [ text <| Maybe.withDefault "" <| Maybe.map Tuple.second <| List.head <| List.drop m.val m.lst ] + , \() -> [ ul [] <| List.indexedMap (\n (_,v) -> li [] [ linkRadio (n == m.val) (\_ -> n) [ text v ] ]) m.lst ] + ) + in case model of + FMCustom m -> f FSCustom (text "Unrecognized query", \() -> [text ""]) -- TODO: Display the Query + FMList m -> f FSList (l m) + FMLang m -> f FSLang (AS.langView m) + FMVPlatform m -> f FSVPlatform (AS.platformView False m) + FMRPlatform m -> f FSRPlatform (AS.platformView True m) + FMLength m -> f FSLength (AS.lengthView m) + FMDevStatus m -> f FSDevStatus (AS.devStatusView m) + FMRole m -> f FSRole (AS.roleView m) + FMBlood m -> f FSBlood (AS.bloodView m) + FMSex m -> f FSSex (AS.sexView m) + FMGender m -> f FSGender (AS.genderView m) + FMMedium m -> f FSMedium (AS.mediumView m) + FMVoiced m -> f FSVoiced (AS.voicedView m) + FMAniEro m -> f FSAniEro (AS.animatedView False m) + FMAniStory m -> f FSAniStory (AS.animatedView True m) + FMRType m -> f FSRType (AS.rtypeView m) + FMLabel m -> f FSLabel (AS.labelView dat m) + FMRList m -> f FSRList (AS.rlistView m) + FMSRole m -> f FSSRole (AS.sroleView m) + FMPType m -> f FSPType (AS.ptypeView m) + FMRExtLinks m -> f FSRExtLinks (AS.extlinkView GEL.releaseSites m) + FMSExtLinks m -> f FSSExtLinks (AS.extlinkView GEL.staffSites m) + FMHeight m -> f FSHeight (AR.heightView m) + FMWeight m -> f FSWeight (AR.weightView m) + FMBust m -> f FSBust (AR.bustView m) + FMWaist m -> f FSWaist (AR.waistView m) + FMHips m -> f FSHips (AR.hipsView m) + FMCup m -> f FSCup (AR.cupView m) + FMAge m -> f FSAge (AR.ageView m) + FMPopularity m -> f FSPopularity (AR.popularityView m) + FMRating m -> f FSRating (AR.ratingView m) + FMVotecount m -> f FSVotecount (AR.votecountView m) + FMMinAge m -> f FSMinAge (AR.minageView m) + FMProdId m -> f FSProdId (AP.view "Name" dat m) + FMProducer m -> f FSProducer (AP.view "Producer" dat m) + FMDeveloper m -> f FSDeveloper (AP.view "Developer" dat m) + FMStaff m -> f FSStaff (AT.view dat m) + FMAnime m -> f FSAnime (AA.view dat m) + FMRDate m -> f FSRDate (AD.view m) + FMResolution m -> f FSResolution (AE.view m) + FMEngine m -> f FSEngine (AEng.view m) + FMDRMType m -> f FSDRMType (ADRM.view m) + FMTag m -> f FSTag (AG.view dat m) + FMTrait m -> f FSTrait (AI.view dat m) + FMBirthday m -> f FSBirthday (AB.view m) + FMNest m -> nestView dat dd m + + +fieldToQuery : Data -> Field -> Maybe Query +fieldToQuery dat (_, _, model) = + case model of + FMCustom m -> Just m + FMList m -> List.drop m.val m.lst |> List.head |> Maybe.map Tuple.first + FMNest m -> nestToQuery dat m + FMLang m -> AS.langToQuery m + FMRPlatform m-> AS.toQuery (QStr 4) m + FMVPlatform m-> AS.toQuery (QStr 4) m + FMLength m -> AS.toQuery (QInt 5) m + FMDevStatus m-> AS.toQuery (QInt 66) m + FMRole m -> AS.toQuery (QStr 2) m + FMBlood m -> AS.toQuery (QStr 3) m + FMSex (s,m) -> AS.toQuery (QStr (if s then 5 else 4)) m + FMGender m -> AS.toQuery (QStr 4) m + FMMedium m -> AS.toQuery (QStr 11) m + FMVoiced m -> AS.toQuery (QInt 12) m + FMAniEro m -> AS.toQuery (QInt 13) m + FMAniStory m -> AS.toQuery (QInt 14) m + FMRType m -> AS.toQuery (QStr 16) m + FMLabel m -> AS.toQuery (\op v -> QTuple 12 op (Maybe.withDefault 0 (Maybe.map vndbidNum dat.uid)) v) m + FMRList m -> AS.toQuery (QInt 18) m + FMSRole m -> AS.toQuery (QStr 5) m + FMPType m -> AS.toQuery (QStr 4) m + FMRExtLinks m-> AS.toQuery (QStr 19) m + FMSExtLinks m-> AS.toQuery (QStr 6) m + FMHeight m -> AR.toQuery (QInt 6) (QStr 6) m + FMWeight m -> AR.toQuery (QInt 7) (QStr 7) m + FMBust m -> AR.toQuery (QInt 8) (QStr 8) m + FMWaist m -> AR.toQuery (QInt 9) (QStr 9) m + FMHips m -> AR.toQuery (QInt 10) (QStr 10) m + FMCup m -> AR.toQuery (QStr 11) (QStr 11) m + FMAge m -> AR.toQuery (QInt 12) (QStr 12) m + FMPopularity m->AR.toQuery (QInt 9) (QStr 9) m + FMRating m -> AR.toQuery (QInt 10) (QStr 10) m + FMVotecount m-> AR.toQuery (QInt 11) (QStr 11) m + FMMinAge m -> AR.toQuery (QInt 10) (QStr 10) m + FMProdId m -> AP.toQuery 3 m + FMProducer m -> AP.toQuery 17 m + FMDeveloper m-> AP.toQuery 6 m + FMStaff m -> AT.toQuery m + FMAnime m -> AA.toQuery m + FMRDate m -> AD.toQuery m + FMResolution m-> AE.toQuery m + FMEngine m -> AEng.toQuery m + FMDRMType m -> ADRM.toQuery m + FMTag m -> AG.toQuery m + FMTrait m -> AI.toQuery m + FMBirthday m -> AB.toQuery m + + +fieldCreate : Int -> (Data,FieldModel) -> (Data,Field) +fieldCreate fid (dat,fm) = + ( {dat | objid = dat.objid + 1} + , (fid, DD.init ("xsearch_field" ++ String.fromInt dat.objid) FToggle, fm) + ) + + +fieldInit : Int -> Data -> (Data,Field) +fieldInit n dat = + case Array.get n fields of + Just f -> fieldCreate n (f.init dat) + Nothing -> fieldCreate -1 (dat, FMCustom (QAnd [])) -- Shouldn't happen. + + +fieldFromQuery : QType -> Data -> Query -> (Data,Field) +fieldFromQuery qtype dat q = + let (field, _) = + Array.foldr (\f (af,n) -> + case (if af /= Nothing || f.ptype /= qtype then Nothing else f.fromQuery dat q) of + Nothing -> (af,n-1) + Just ret -> (Just (fieldCreate n ret), 0) + ) (Nothing,Array.length fields-1) fields + in case field of + Just ret -> ret + Nothing -> fieldCreate -1 (dat, FMCustom q) + + +fieldSub : Field -> Sub FieldMsg +fieldSub (_,dd,fm) = + case fm of + FMNest m -> + Sub.batch + <| DD.sub dd + :: DD.sub m.addDd + :: DD.sub m.andDd + :: List.indexedMap (\i -> Sub.map (FSNest << NField i) << fieldSub) m.fields + _ -> DD.sub dd |