/src/Parameters/App.elm at edd24c87bbc44054e37bb4e649bd5e5c3ca77493

-- Copyright 2026 Shota FUJI
--
-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.
--
-- SPDX-License-Identifier: MPL-2.0


module Parameters.App exposing (Model, Msg, init, update, view)

import Dict exposing (Dict)
import Html exposing (hr, input, label, node, p, span, text)
import Html.Attributes exposing (..)
import Html.Events exposing (onInput)
import Html.LivingStandard exposing (..)
import Length exposing (Length, toMM)
import Parameters exposing (ColorSchema(..), Parameters, colorSchemaToString, defaultFixedLoop, defaultFreeLoop)
import Parameters.Constraints exposing (NumberConstraints, constraints)
import Parameters.Key as Key exposing (Key(..))
import Parameters.Parser exposing (..)



-- MODEL


type alias Fields =
    Dict String String


type alias Errors =
    Dict String Error


type alias Model =
    { fields : Fields
    , errors : Errors
    , parameters : Parameters
    }


init : Parameters -> Model
init params =
    let
        fields =
            Dict.fromList
                [ ( Key.toString LugWidth, String.fromFloat (toMM params.lugWidth) )
                , ( Key.toString SurfaceThickness, String.fromFloat (toMM params.thickness) )
                , ( Key.toString LiningThickness, String.fromFloat (toMM params.lining) )
                , ( Key.toString BuckleHoleCount, String.fromInt params.longPiece.buckleHole.count )
                , ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) )
                , ( Key.toString LoopThickness, String.fromFloat (toMM params.shortPiece.loops.thickness) )
                , ( Key.toString HasFixedLoop
                  , if params.shortPiece.loops.fixed == Nothing then
                        "false"

                    else
                        "true"
                  )
                , ( Key.toString FixedLoopWidth
                  , params.shortPiece.loops.fixed |> Maybe.withDefault defaultFixedLoop |> .width |> toMM |> String.fromFloat
                  )
                , ( Key.toString FixedLoopPlay
                  , params.shortPiece.loops.fixed |> Maybe.withDefault defaultFixedLoop |> .play |> toMM |> String.fromFloat
                  )
                , ( Key.toString HasFreeLoop
                  , if params.shortPiece.loops.free == Nothing then
                        "false"

                    else
                        "true"
                  )
                , ( Key.toString FreeLoopWidth
                  , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .width |> toMM |> String.fromFloat
                  )
                , ( Key.toString FreeLoopPlay
                  , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .play |> toMM |> String.fromFloat
                  )
                , ( Key.toString FreeLoopOverlap
                  , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .overlap |> toMM |> String.fromFloat
                  )
                , ( Key.toString CanvasMargin, String.fromFloat (toMM params.rendering.margin) )
                , ( Key.toString LineWidth, String.fromFloat (toMM params.rendering.lineWidth) )
                , ( Key.toString ColorSchema, colorSchemaToString params.rendering.colorSchema )
                ]
    in
    { fields = fields
    , errors =
        case parse fields of
            Ok _ ->
                Dict.empty

            Err errors ->
                errors
    , parameters = params
    }



-- UPDATE


type Msg
    = FieldChanged Key String
    | ColorSchemaChanged ColorSchema


parseField : Key -> (String -> Result Error a) -> Fields -> Result Error a
parseField key f fields =
    Dict.get (Key.toString key) fields
        |> Maybe.withDefault ""
        |> f


mkErrors : List ( Key, Maybe Error ) -> Errors
mkErrors list =
    list
        |> List.filterMap (\( key, error ) -> Maybe.map (\e -> ( Key.toString key, e )) error)
        |> Dict.fromList


getError : Result a b -> Maybe a
getError r =
    case r of
        Err e ->
            Just e

        _ ->
            Nothing


parseFixedLoop : Fields -> Result Errors (Maybe Parameters.FixedLoop)
parseFixedLoop fields =
    case parseField HasFixedLoop parseBool fields of
        Ok True ->
            case
                ( parseField FixedLoopWidth (parseLength constraints.shortPiece.loops.fixed.width) fields
                , parseField FixedLoopPlay (parseLength constraints.shortPiece.loops.fixed.play) fields
                )
            of
                ( Ok width, Ok play ) ->
                    let
                        base =
                            Parameters.defaultFixedLoop
                    in
                    Ok (Just { base | width = width, play = play })

                ( width, play ) ->
                    Err
                        (mkErrors
                            [ ( FixedLoopWidth, getError width )
                            , ( FixedLoopPlay, getError play )
                            ]
                        )

        _ ->
            Ok Nothing


parseFreeLoop : Fields -> Result Errors (Maybe Parameters.FreeLoop)
parseFreeLoop fields =
    case parseField HasFreeLoop parseBool fields of
        Ok True ->
            case
                ( parseField FreeLoopWidth (parseLength constraints.shortPiece.loops.free.width) fields
                , parseField FreeLoopPlay (parseLength constraints.shortPiece.loops.free.play) fields
                , parseField FreeLoopOverlap (parseLength constraints.shortPiece.loops.free.overlap) fields
                )
            of
                ( Ok width, Ok play, Ok overlap ) ->
                    Ok (Just { width = width, play = play, overlap = overlap })

                ( width, play, overlap ) ->
                    Err
                        (mkErrors
                            [ ( FreeLoopWidth, getError width )
                            , ( FreeLoopPlay, getError play )
                            , ( FreeLoopOverlap, getError overlap )
                            ]
                        )

        _ ->
            Ok Nothing


parseLoops : Fields -> Result Errors Parameters.Loops
parseLoops fields =
    case ( parseFixedLoop fields, parseFreeLoop fields ) of
        ( Ok fixed, Ok free ) ->
            let
                base =
                    Parameters.default.shortPiece.loops
            in
            Ok { base | fixed = fixed, free = free }

        ( fixed, free ) ->
            Err
                (Dict.union
                    (getError fixed |> Maybe.withDefault Dict.empty)
                    (getError free |> Maybe.withDefault Dict.empty)
                )


parseShortPiece : Fields -> Result Errors Parameters.ShortPiece
parseShortPiece fields =
    case parseLoops fields of
        Ok loops ->
            let
                base =
                    Parameters.default.shortPiece
            in
            Ok { base | loops = loops }

        Err errs ->
            Err errs


parseBuckleHole : Fields -> Result Errors Parameters.BuckleHole
parseBuckleHole fields =
    case
        ( parseField BuckleHoleCount (parseInt constraints.longPiece.buckleHole.count) fields
        , parseField BuckleHoleDiameter (parseLength constraints.longPiece.buckleHole.diameter) fields
        )
    of
        ( Ok count, Ok diameter ) ->
            let
                base =
                    Parameters.default.longPiece.buckleHole
            in
            Ok { base | count = count, diameter = diameter }

        ( count, diameter ) ->
            Err
                (mkErrors
                    [ ( BuckleHoleCount, getError count )
                    , ( BuckleHoleDiameter, getError diameter )
                    ]
                )


parseLongPiece : Fields -> Result Errors Parameters.LongPiece
parseLongPiece fields =
    case parseBuckleHole fields of
        Ok buckleHole ->
            let
                base =
                    Parameters.default.longPiece
            in
            Ok { base | buckleHole = buckleHole }

        Err errors ->
            Err errors


parseCanvas : Fields -> Result Errors Parameters.Rendering
parseCanvas fields =
    case
        ( parseField CanvasMargin (parseLength constraints.rendering.margin) fields
        , parseField LineWidth (parseLength constraints.rendering.lineWidth) fields
        , parseField ColorSchema parseColorSchema fields
        )
    of
        ( Ok margin, Ok lineWidth, Ok colorSchema ) ->
            let
                base =
                    Parameters.default.rendering
            in
            Ok { base | margin = margin, lineWidth = lineWidth, colorSchema = colorSchema }

        ( margin, lineWidth, colorSchema ) ->
            Err
                (mkErrors
                    [ ( CanvasMargin, getError margin )
                    , ( LineWidth, getError lineWidth )
                    , ( ColorSchema, getError colorSchema )
                    ]
                )


parse : Fields -> Result Errors Parameters
parse fields =
    case
        ( ( parseField LugWidth (parseLength constraints.lugWidth) fields
          , parseField LiningThickness (parseLength constraints.lining) fields
          , parseField SurfaceThickness (parseLength constraints.thickness) fields
          )
        , ( parseLongPiece fields
          , parseShortPiece fields
          )
        , parseCanvas fields
        )
    of
        ( ( Ok lugWidth, Ok lining, Ok thickness ), ( Ok longPiece, Ok shortPiece ), Ok rendering ) ->
            let
                base =
                    Parameters.default
            in
            Ok
                { base
                    | lugWidth = lugWidth
                    , lining = lining
                    , thickness = thickness
                    , longPiece = longPiece
                    , shortPiece = shortPiece
                    , rendering = rendering
                }

        ( ( lugWidth, lining, thickness ), ( longPiece, shortPiece ), rendering ) ->
            [ mkErrors [ ( LugWidth, getError lugWidth ) ]
            , mkErrors [ ( LiningThickness, getError lining ) ]
            , mkErrors [ ( SurfaceThickness, getError thickness ) ]
            , getError longPiece |> Maybe.withDefault Dict.empty
            , getError shortPiece |> Maybe.withDefault Dict.empty
            , getError rendering |> Maybe.withDefault Dict.empty
            ]
                |> List.map Dict.toList
                |> List.concat
                |> Dict.fromList
                |> Err


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
    case msg of
        FieldChanged key value ->
            let
                fields =
                    Dict.insert (Key.toString key) value model.fields
            in
            case parse fields of
                Ok newParams ->
                    ( { model
                        | fields = fields
                        , errors = Dict.empty
                        , parameters = newParams
                      }
                    , Cmd.none
                    )

                Err errors ->
                    ( { model | fields = fields, errors = errors }, Cmd.none )

        ColorSchemaChanged schema ->
            let
                { parameters } =
                    model

                { rendering } =
                    parameters
            in
            ( { model | parameters = { parameters | rendering = { rendering | colorSchema = schema } } }
            , Cmd.none
            )



-- VIEW


lengthFieldAttrs : NumberConstraints Length -> List (Html.Attribute msg)
lengthFieldAttrs { min, max } =
    [ case min of
        Just x ->
            toMM x
                |> String.fromFloat
                |> Html.Attributes.min

        Nothing ->
            class ""
    , case max of
        Just x ->
            toMM x
                |> String.fromFloat
                |> Html.Attributes.max

        Nothing ->
            class ""
    , attribute "inputmode" "numeric"
    , required True
    ]


intFieldAttrs : NumberConstraints Int -> List (Html.Attribute msg)
intFieldAttrs { min, max } =
    [ case min of
        Just x ->
            Html.Attributes.min (String.fromInt x)

        Nothing ->
            class ""
    , case max of
        Just x ->
            Html.Attributes.max (String.fromInt x)

        Nothing ->
            class ""
    , attribute "inputmode" "numeric"
    , required True
    ]


ariaInvalid : Bool -> Html.Attribute msg
ariaInvalid invalid =
    attribute "aria-invalid"
        (if invalid then
            "true"

         else
            "false"
        )


ariaDescribedBy : List String -> Html.Attribute msg
ariaDescribedBy ids =
    case ids of
        [] ->
            class ""

        _ ->
            ids
                |> String.join " "
                |> attribute "aria-describedby"


errorId : Key -> String
errorId key =
    Key.toString key ++ "_error"


errorText : Error -> List (Html.Html msg)
errorText e =
    case e of
        MissingValue ->
            [ text "This field is required." ]

        BelowMin n ->
            [ text ("Value must be greater than or equals to " ++ String.fromFloat n ++ ".") ]

        AboveMax n ->
            [ text ("Value must be less than or equals to " ++ String.fromFloat n ++ ".") ]

        NotALength ->
            [ text "Invalid length value. Set an integer or a floating point number." ]

        NotAnInt ->
            [ text "Invalid integer value. This field only accepts integer value." ]

        NotABool ->
            [ text "Invalid bool value. Value must be either \"true\" or \"false\"." ]

        NonexistentVariant str ->
            [ text ("\"" ++ str ++ "\" is not a valid choice. Did you modify program's source code?") ]


descriptionId : Key -> String
descriptionId key =
    Key.toString key ++ "_description"


type alias NumberFieldProps msg =
    { key : Key
    , title : List (Html.Html msg)
    , description : List (Html.Html msg)
    , unit : Maybe String
    , attrs : List (Html.Attribute msg)
    , disabled : Bool
    }


numberField : Model -> NumberFieldProps Msg -> Html.Html Msg
numberField model { key, title, description, attrs, unit, disabled } =
    node "x-field"
        [ if disabled then
            attribute "disabled" ""

          else
            class ""
        ]
        [ label [ for (Key.toString key), slot "title" ] title
        , p
            [ id (descriptionId key), slot "description" ]
            description
        , node "x-number-input"
            []
            [ input
                (id (Key.toString key)
                    :: value (model.fields |> Dict.get (Key.toString key) |> Maybe.withDefault "")
                    :: onInput (FieldChanged key)
                    :: ariaInvalid (not (Dict.get (Key.toString key) model.errors == Nothing))
                    :: ariaDescribedBy [ errorId key, descriptionId key ]
                    :: Html.Attributes.disabled disabled
                    :: attrs
                )
                []
            , case unit of
                Just u ->
                    span [ slot "unit" ] [ text u ]

                Nothing ->
                    text ""
            ]
        , p
            [ id (errorId key), slot "error" ]
            (Dict.get (Key.toString key) model.errors
                |> Maybe.map errorText
                |> Maybe.withDefault []
            )
        ]


type alias ChoiceFieldProps msg =
    { key : Key
    , title : List (Html.Html msg)
    , description : List (Html.Html msg)
    , attrs : List (Html.Attribute msg)
    , choices :
        List
            { value : String
            , label : List (Html.Html msg)
            , description : List (Html.Html msg)
            }
    }


choiceField : Model -> ChoiceFieldProps Msg -> Html.Html Msg
choiceField model { key, title, description, attrs, choices } =
    node "x-field"
        []
        (span [ slot "title" ] title
            :: p [ slot "description" ] description
            :: List.map
                (\choice ->
                    let
                        id =
                            Key.toString key ++ "_" ++ choice.value

                        choiceDescriptionId =
                            id ++ "__description"

                        checked =
                            Dict.get (Key.toString key) model.fields
                                |> Maybe.withDefault ""
                                |> (==) choice.value
                    in
                    node "x-radio-box"
                        [ if checked then
                            attribute "checked" ""

                          else
                            class ""
                        ]
                        [ Html.label [ for id, slot "label" ] choice.label
                        , Html.p [ Html.Attributes.id choiceDescriptionId, slot "description" ] description
                        , input
                            (type_ "radio"
                                :: Html.Attributes.id id
                                :: Html.Attributes.name (Key.toString key)
                                :: Html.Attributes.value choice.value
                                :: Html.Attributes.checked checked
                                :: Html.Events.onCheck (\_ -> FieldChanged key choice.value)
                                :: ariaDescribedBy [ choiceDescriptionId ]
                                :: attrs
                            )
                            []
                        ]
                )
                choices
        )


type alias GroupProps msg =
    { title : List (Html.Html msg)
    , description : Maybe (List (Html.Html msg))
    }


group : GroupProps Msg -> List (Html.Html Msg) -> Html.Html Msg
group { title, description } children =
    node "x-field-group"
        []
        (p [ slot "title" ] title
            :: (description |> Maybe.map (p [ slot "description" ]) |> Maybe.withDefault (text ""))
            :: children
        )


view : Model -> List (Html.Html Msg)
view model =
    [ group
        { title = [ text "General" ], description = Nothing }
        [ numberField model
            { key = LugWidth
            , title = [ text "Lug width" ]
            , description =
                [ text "This will be the final width of your strap. "
                , text "You can use a size smaller than your lug width to create a play."
                ]
            , unit = Just "mm"
            , disabled = False
            , attrs = step "1.0" :: lengthFieldAttrs constraints.lugWidth
            }
        , numberField model
            { key = SurfaceThickness
            , title = [ text "Surface Leather Thickness" ]
            , description = [ text "Thickness of surface leather." ]
            , unit = Just "mm"
            , disabled = False
            , attrs = step "0.1" :: lengthFieldAttrs constraints.thickness
            }
        , numberField model
            { key = LiningThickness
            , title = [ text "Lining Leather Thickness" ]
            , description =
                [ text "Thickness of lining leather. Set to 0 to disable lining generation."
                ]
            , unit = Just "mm"
            , disabled = False
            , attrs = step "0.1" :: lengthFieldAttrs constraints.lining
            }
        ]
    , hr [] []
    , group
        { title = [ text "Buckle / Clasp" ], description = Nothing }
        [ numberField model
            { key = BuckleHoleCount
            , title = [ text "Hole Count" ]
            , description = [ text "Set 0 to disable buckle holes generation." ]
            , unit = Nothing
            , disabled = False
            , attrs = step "1" :: intFieldAttrs constraints.longPiece.buckleHole.count
            }
        , numberField model
            { key = BuckleHoleDiameter
            , title = [ text "Hole Diameter" ]
            , description =
                [ text "Diameter of buckle holes. You can leave the default value if you're going to use the center mark." ]
            , unit = Just "mm"
            , disabled = model.parameters.longPiece.buckleHole.count == 0
            , attrs =
                step "1.0" :: lengthFieldAttrs constraints.longPiece.buckleHole.diameter
            }
        ]
    , hr [] []
    , group
        { title = [ text "Loops" ], description = Nothing }
        [ choiceField model
            { key = HasFixedLoop
            , title = [ text "Fixed Loop" ]
            , description = [ text "Whether to draw fixed loop. Certain kind of deployant buckles don't require a fixed loop." ]
            , attrs = []
            , choices =
                [ { label = [ text "Enabled" ]
                  , description = [ text "Output fixed loop." ]
                  , value = "true"
                  }
                , { label = [ text "Disabled" ]
                  , description = [ text "Do not output fixed loop." ]
                  , value = "false"
                  }
                ]
            }
        , numberField model
            { key = FixedLoopWidth
            , title = [ text "Fixed Loop Width" ]
            , description = [ text "Width of the fixed loop." ]
            , unit = Just "mm"
            , disabled = not (Dict.get (Key.toString HasFixedLoop) model.fields == Just "true")
            , attrs =
                step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.fixed.width
            }
        , numberField model
            { key = FixedLoopPlay
            , title = [ text "Fixed Loop Play" ]
            , description = [ text "Extra length to add to the fixed loop, for adjusting tightness." ]
            , unit = Just "mm"
            , disabled = not (Dict.get (Key.toString HasFixedLoop) model.fields == Just "true")
            , attrs =
                step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.fixed.play
            }
        , choiceField model
            { key = HasFreeLoop
            , title = [ text "Free Loop" ]
            , description = [ text "Whether to draw free loop. Certain kind of deployant buckles don't require a free loop." ]
            , attrs = []
            , choices =
                [ { label = [ text "Enabled" ]
                  , description = [ text "Output free loop." ]
                  , value = "true"
                  }
                , { label = [ text "Disabled" ]
                  , description = [ text "Do not output free loop." ]
                  , value = "false"
                  }
                ]
            }
        , numberField model
            { key = FreeLoopWidth
            , title = [ text "Free Loop Width" ]
            , description = [ text "Width of the free loop." ]
            , unit = Just "mm"
            , disabled = not (Dict.get (Key.toString HasFreeLoop) model.fields == Just "true")
            , attrs =
                step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.free.width
            }
        , numberField model
            { key = FreeLoopPlay
            , title = [ text "Free Loop Play" ]
            , description = [ text "Extra length to add to the free loop, for adjusting tightness." ]
            , unit = Just "mm"
            , disabled = not (Dict.get (Key.toString HasFreeLoop) model.fields == Just "true")
            , attrs =
                step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.free.play
            }
        , numberField model
            { key = FreeLoopOverlap
            , title = [ text "Free Loop Overlap" ]
            , description = [ text "Length of overlapping section of the free loop for gluing and/or stitching." ]
            , unit = Just "mm"
            , disabled = not (Dict.get (Key.toString HasFreeLoop) model.fields == Just "true")
            , attrs =
                step "0.1" :: lengthFieldAttrs constraints.shortPiece.loops.free.overlap
            }
        ]
    , hr [] []
    , group
        { title = [ text "Rendering" ], description = Nothing }
        [ numberField model
            { key = CanvasMargin
            , title = [ text "Print Margin" ]
            , description =
                [ text "Lower values can cause printing problems depending on your printer." ]
            , unit = Just "mm"
            , disabled = False
            , attrs = step "1.0" :: lengthFieldAttrs constraints.rendering.margin
            }
        , numberField model
            { key = LineWidth
            , title = [ text "Line Width" ]
            , description =
                [ text "Stroke width (thickness) of the cutting lines and seam lines." ]
            , unit = Just "mm"
            , disabled = False
            , attrs = step "0.1" :: lengthFieldAttrs constraints.rendering.lineWidth
            }
        , choiceField model
            { key = ColorSchema
            , title = [ text "Color Schema" ]
            , description = [ text "Color schema of the template." ]
            , attrs = []
            , choices =
                [ { label = [ text "Black on White" ]
                  , description = [ text "Select this if you print the template with a regular printer." ]
                  , value = colorSchemaToString BlackOnWhite
                  }
                , { label = [ text "White on Black" ]
                  , description = [ text "For digital output. Printing this with an inkjet printer is not a good idea." ]
                  , value = colorSchemaToString WhiteOnBlack
                  }
                ]
            }
        ]
    ]