Add taper parameter

Changes

6 changed files (+270/-115)

• src/Parameters.elm
  • @@ -18,10 +18,6 @@ type TipShape
    = Round - type Profile - = Straight - - type alias BuckleHole = -- Offset from the case side (lug side.) { offset : Length
  • @@ -150,9 +146,9 @@ type alias Parameters =
    { lugWidth : Length , longPiece : LongPiece , shortPiece : ShortPiece - , profile : Profile , thickness : Length , lining : Length + , taper : Length , rendering : Rendering }
  • @@ -209,9 +205,9 @@ { springBarDiameter = mm 1.4
    , tongue = Just defaultBuckleTongue } } - , profile = Straight , thickness = mm 2.5 , lining = mm 0.5 + , taper = mm 0 , rendering = { size = A4 , margin = mm 3
  • @@ -241,12 +237,19 @@ , ( 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 ) , ( Key.toString BuckleHoleCount, String.fromInt params.longPiece.buckleHole.count ) + , ( Key.toString BuckleHoleOffset, String.fromFloat (toMM params.longPiece.buckleHole.offset) ) + , ( Key.toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) ] |> (++) + (if toMM params.taper > 0 then + [ ( Key.toString Taper, String.fromFloat (toMM params.taper) ) ] + + else + [] + ) + |> (++) (if params.longPiece.buckleHole.count > 0 then - [ ( Key.toString BuckleHoleOffset, String.fromFloat (toMM params.longPiece.buckleHole.offset) ) - , ( Key.toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) - , ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) + [ ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) ] else
  • @@ -294,15 +297,14 @@ `Nothing`. These values sets default values for those fields.
    -} fallbackValues : ParametersDict fallbackValues = - [ ( Key.toString FixedLoopWidth, String.fromFloat (toMM defaultFixedLoop.width) ) + [ ( Key.toString Taper, "0" ) + , ( Key.toString FixedLoopWidth, String.fromFloat (toMM defaultFixedLoop.width) ) , ( Key.toString FixedLoopPlay, String.fromFloat (toMM defaultFixedLoop.play) ) , ( Key.toString FreeLoopWidth, String.fromFloat (toMM defaultFreeLoop.width) ) , ( Key.toString FreeLoopPlay, String.fromFloat (toMM defaultFreeLoop.play) ) , ( Key.toString FreeLoopOverlap, String.fromFloat (toMM defaultFreeLoop.overlap) ) , ( Key.toString BuckleTongueThickness, String.fromFloat (toMM defaultBuckleTongue.thickness) ) , ( Key.toString BuckleTongueWidth, String.fromFloat (toMM defaultBuckleTongue.width) ) - , ( Key.toString BuckleHoleOffset, String.fromFloat (toMM default.longPiece.buckleHole.offset) ) - , ( Key.toString BuckleHoleInterval, String.fromFloat (toMM default.longPiece.buckleHole.interval) ) , ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM default.longPiece.buckleHole.diameter) ) ] |> Dict.fromList
• src/Parameters/App.elm
  • @@ -538,6 +538,22 @@ , disabled = False
    , attrs = step "1.0" :: lengthFieldAttrs constraints.lugWidth } , numberField model + { key = Taper + , title = [ text "Taper" ] + , description = + [ text "Taper size. " + , text (String.fromFloat (toMM model.parameters.taper)) + , text "mm taper makes the strap " + , text (String.fromFloat (toMM model.parameters.lugWidth)) + , text "/" + , text (String.fromFloat (toMM model.parameters.lugWidth - toMM model.parameters.taper)) + , text "mm." + ] + , unit = Just "mm" + , disabled = False + , attrs = step "1" :: lengthFieldAttrs constraints.taper + } + , numberField model { key = SurfaceThickness , title = [ text "Surface Leather Thickness" ] , description = [ text "Thickness of surface leather." ]
  • @@ -588,24 +604,24 @@ , disabled = False
    , attrs = step "1" :: intFieldAttrs constraints.longPiece.buckleHole.count } , numberField model - { key = BuckleHoleOffset - , title = [ text "Hole Offset" ] + { key = BuckleHoleDiameter + , title = [ text "Hole Diameter" ] , description = - [ text "Distance between strap end (lug-side) and first buckle hole." ] + [ 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.offset + step "1.0" :: lengthFieldAttrs constraints.longPiece.buckleHole.diameter } , numberField model - { key = BuckleHoleDiameter - , title = [ text "Hole Diameter" ] + { key = BuckleHoleOffset + , title = [ text "Hole Offset" ] , description = - [ text "Diameter of buckle holes. You can leave the default value if you're going to use the center mark." ] + [ text "Distance between strap end (lug-side) and first buckle hole." ] , unit = Just "mm" - , disabled = model.parameters.longPiece.buckleHole.count == 0 + , disabled = False , attrs = - step "1.0" :: lengthFieldAttrs constraints.longPiece.buckleHole.diameter + step "1.0" :: lengthFieldAttrs constraints.longPiece.buckleHole.offset } , numberField model { key = BuckleHoleInterval
  • @@ -613,7 +629,7 @@ , title = [ text "Hole Interval" ]
    , description = [ text "Center-to-center interval between buckle holes." ] , unit = Just "mm" - , disabled = model.parameters.longPiece.buckleHole.count == 0 + , disabled = False , attrs = step "0.5" :: lengthFieldAttrs constraints.longPiece.buckleHole.interval }
• src/Parameters/Constraints.elm
  • @@ -84,6 +84,7 @@ , longPiece : LongPiece
    , shortPiece : ShortPiece , lining : NumberConstraints Length , thickness : NumberConstraints Length + , taper : NumberConstraints Length , rendering : Rendering }
  • @@ -124,6 +125,7 @@ }
    } , lining = { min = Just (mm 0), max = Just (mm 5) } , thickness = { min = Just (mm 0.1), max = Just (mm 5) } + , taper = { min = Just (mm 0), max = Just (mm 8) } , rendering = { margin = { min = Just (mm 0), max = Just (mm 20) } , lineWidth = { min = Just (mm 0.1), max = Just (mm 1) }
• src/Parameters/Key.elm
  • @@ -12,6 +12,7 @@
    type Key = LugWidth + | Taper | SurfaceThickness | LiningThickness | BuckleHoleOffset
  • @@ -44,6 +45,9 @@ toString key =
    case key of Version -> "version" + + Taper -> + "taper" LugWidth -> "lug-width"
• src/Parameters/Parser.elm
  • @@ -172,6 +172,13 @@ |> Maybe.withDefault ""
    |> f + parseFieldWithDefault : Key -> a -> (String -> Result Error a) -> ParametersDict -> Result Error a + parseFieldWithDefault key default f fields = + getKey key fields + |> Maybe.map f + |> Maybe.withDefault (Ok default) + + parseFixedLoop : ParametersDict -> Result Errors (Maybe Parameters.FixedLoop) parseFixedLoop fields = if hasKey HasFixedLoop fields then
  • @@ -402,29 +409,29 @@ , parseField SurfaceThickness (parseLength constraints.thickness) fields
    ) , ( parseLongPiece fields , parseShortPiece fields + , parseFieldWithDefault Taper (mm 0) (parseLength constraints.taper) fields ) , parseCanvas fields ) of - ( ( Ok lugWidth, Ok lining, Ok thickness ), ( Ok longPiece, Ok shortPiece ), Ok rendering ) -> - let - base = - Parameters.default - in + ( ( Ok lugWidth, Ok lining, Ok thickness ), ( Ok longPiece, Ok shortPiece, Ok taper ), Ok rendering ) -> Ok - { base - | lugWidth = lugWidth - , lining = lining - , thickness = thickness - , longPiece = longPiece - , shortPiece = shortPiece - , rendering = rendering + { lugWidth = lugWidth + , lining = lining + , thickness = thickness + , longPiece = longPiece + , shortPiece = shortPiece + , rendering = rendering + , taper = taper } - ( ( lugWidth, lining, thickness ), ( longPiece, shortPiece ), rendering ) -> - [ mkErrors [ ( LugWidth, getError lugWidth ) ] - , mkErrors [ ( LiningThickness, getError lining ) ] - , mkErrors [ ( SurfaceThickness, getError thickness ) ] + ( ( lugWidth, lining, thickness ), ( longPiece, shortPiece, taper ), rendering ) -> + [ mkErrors + [ ( LugWidth, getError lugWidth ) + , ( LiningThickness, getError lining ) + , ( SurfaceThickness, getError thickness ) + , ( Taper, getError taper ) + ] , getError longPiece |> Maybe.withDefault Dict.empty , getError shortPiece |> Maybe.withDefault Dict.empty , getError rendering |> Maybe.withDefault Dict.empty
• src/Template/Cuts.elm
  • @@ -90,6 +90,76 @@ , strokeDasharray "1 0.5"
    ] + longPieceShape : ( Float, Float ) -> Parameters -> Maybe Key -> List Path.PathCommand -> Svg msg + longPieceShape ( x, y ) params highlighting commands = + let + lugWidth = + toMM params.lugWidth + + length = + toMM params.longPiece.length + + taperUntil = + Basics.min + (toMM params.longPiece.buckleHole.offset - toMM params.longPiece.buckleHole.interval) + (length / 2) + + taper = + toMM params.taper + + buckleWidth = + lugWidth - taper + in + Svg.path + [ Path.d + (MoveTo Absolute ( x, y ) + :: CubicBezierCurve Relative + ( ( taper / 2, taperUntil ) + , ( taper / 2, taperUntil ) + , ( taper / 2, length - buckleWidth / 2 ) + ) + [] + :: EllipticalArcCurve Relative + { rx = buckleWidth / 2 + , ry = buckleWidth / 2 + , angle = 0.0 + , largeArcFlag = LargeArc + , sweepFlag = Counterclockwise + , x = buckleWidth + , y = 0 + } + [] + :: CubicBezierCurve Absolute + ( ( x + lugWidth - taper / 2, y + taperUntil ) + , ( x + lugWidth - taper / 2, y + taperUntil ) + , ( x + lugWidth, y ) + ) + [] + :: commands + ) + , fill "none" + , stroke "currentColor" + , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) + , highlightStroke + (highlighting + == Just LongPieceLength + || highlighting + == Just LugWidth + || highlighting + == Just Taper + || (toMM params.taper + > 0 + && (highlighting + == Just BuckleHoleOffset + || highlighting + == Just BuckleHoleInterval + ) + ) + ) + ] + [] + + longPiece : Parameters -> Maybe Key -> Item msg longPiece params highlighting = let
  • @@ -107,29 +177,15 @@ , element =
    \p _ -> g [] - (Svg.path - [ Path.d - [ MoveTo Absolute ( p.x, p.y ) - , VerticalLineTo Relative (length + flap - lugWidth / 2) - , EllipticalArcCurve Relative - { rx = lugWidth / 2 - , ry = lugWidth / 2 - , angle = 0.0 - , largeArcFlag = LargeArc - , sweepFlag = Counterclockwise - , x = lugWidth - , y = 0 - } - [] - , VerticalLineTo Relative -(length + flap - lugWidth / 2) - , ClosePath - ] - , fill "none" - , stroke "currentColor" - , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) - , highlightStroke (highlighting == Just LongPieceLength || highlighting == Just LugWidth) + (longPieceShape + ( p.x, p.y + flap ) + params + highlighting + [ VerticalLineTo Relative -flap + , HorizontalLineTo Relative -lugWidth + , VerticalLineTo Relative flap + , ClosePath ] - [] :: Svg.path (Path.d [ MoveTo Absolute ( p.x, p.y + flap )
  • @@ -226,11 +282,111 @@ ]
    ] + type alias ShortPieceOptions = + { includeCaseSideFlap : Bool + , includeClaspSideFlap : Bool + , at : ( Float, Float ) + } + + + shortPieceShape : Parameters -> Maybe Key -> ShortPieceOptions -> Svg msg + shortPieceShape params highlighting { includeCaseSideFlap, includeClaspSideFlap, at } = + let + lugWidth = + toMM params.lugWidth + + length = + toMM params.shortPiece.length + + taperUntil = + Basics.min + (toMM params.longPiece.buckleHole.offset - toMM params.longPiece.buckleHole.interval) + (length / 2) + + taper = + toMM params.taper + + ( x, y ) = + at + in + Svg.path + [ Path.d + ([ Just (MoveTo Absolute ( x, y )) + , if includeCaseSideFlap then + Just (VerticalLineTo Relative (toMM params.shortPiece.caseSideFlap)) + + else + Nothing + , Just + (CubicBezierCurve Relative + ( ( taper / 2, taperUntil ) + , ( taper / 2, taperUntil ) + , ( taper / 2, length ) + ) + [] + ) + , if includeClaspSideFlap then + Just (VerticalLineTo Relative (toMM params.shortPiece.claspSideFlap)) + + else + Nothing + , Just (HorizontalLineTo Relative (lugWidth - taper)) + , if includeClaspSideFlap then + Just (VerticalLineTo Relative -(toMM params.shortPiece.claspSideFlap)) + + else + Nothing + , Just + (CubicBezierCurve Relative + ( ( 0, -length + taperUntil ) + , ( 0, -length + taperUntil ) + , ( taper / 2, -length ) + ) + [] + ) + , if includeCaseSideFlap then + Just (VerticalLineTo Relative -(toMM params.shortPiece.caseSideFlap)) + + else + Nothing + , Just ClosePath + ] + |> List.filterMap identity + ) + , fill "none" + , stroke "currentColor" + , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) + , highlightStroke + (highlighting + == Just ShortPieceLength + || highlighting + == Just LugWidth + || highlighting + == Just Taper + || (toMM params.taper + > 0 + && (highlighting + == Just BuckleHoleOffset + || highlighting + == Just BuckleHoleInterval + ) + ) + ) + ] + [] + + shortPiece : Parameters -> Maybe Key -> Item msg shortPiece params highlighting = let lugWidth = toMM params.lugWidth + + taper = + toMM params.taper + + buckleWidth = + lugWidth - taper length = toMM params.shortPiece.length
  • @@ -247,20 +403,12 @@ , element =
    \p _ -> g [] - [ Svg.path - [ Path.d - [ MoveTo Absolute ( p.x, p.y ) - , VerticalLineTo Relative (length + caseSideFlap + claspSideFlap) - , HorizontalLineTo Relative lugWidth - , VerticalLineTo Relative -(length + caseSideFlap + claspSideFlap) - , ClosePath - ] - , fill "none" - , stroke "currentColor" - , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) - , highlightStroke (highlighting == Just ShortPieceLength || highlighting == Just LugWidth) - ] - [] + [ shortPieceShape params + highlighting + { includeCaseSideFlap = True + , includeClaspSideFlap = True + , at = ( p.x, p.y ) + } , case params.shortPiece.buckle.tongue of Just { thickness, width } -> let
  • @@ -311,8 +459,8 @@ ]
    [] , Svg.path [ Path.d - [ MoveTo Absolute ( p.x, p.y + caseSideFlap + length ) - , HorizontalLineTo Relative lugWidth + [ MoveTo Absolute ( p.x + taper / 2, p.y + caseSideFlap + length ) + , HorizontalLineTo Relative buckleWidth ] ] []
  • @@ -331,10 +479,10 @@ ]
    [] , Svg.path [ Path.d - [ MoveTo Absolute ( p.x, p.y + caseSideFlap + length ) - , HorizontalLineTo Relative lugWidth + [ MoveTo Absolute ( p.x + taper / 2, p.y + caseSideFlap + length ) + , HorizontalLineTo Relative buckleWidth , VerticalLineTo Relative claspSideFlap - , HorizontalLineTo Relative -lugWidth + , HorizontalLineTo Relative -buckleWidth , ClosePath ] ]
  • @@ -384,29 +532,13 @@ { size =
    { width = Exactly lugWidth, height = Exactly length } , element = \p _ -> - Svg.path - [ Path.d - [ MoveTo Absolute ( p.x, p.y ) - , VerticalLineTo Relative (length - lugWidth / 2) - , EllipticalArcCurve Relative - { rx = lugWidth / 2 - , ry = lugWidth / 2 - , angle = 0.0 - , largeArcFlag = LargeArc - , sweepFlag = Counterclockwise - , x = lugWidth - , y = 0 - } - [] - , VerticalLineTo Relative -(length - lugWidth / 2) - , ClosePath - ] - , fill "none" - , stroke "currentColor" - , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) - , highlightStroke (highlighting == Just LugWidth || highlighting == Just LongPieceLength) + longPieceShape + ( p.x, p.y ) + params + highlighting + [ HorizontalLineTo Relative -lugWidth + , ClosePath ] - [] }
  • @@ -423,20 +555,12 @@ { size =
    { width = Exactly lugWidth, height = Exactly length } , element = \p _ -> - Svg.path - [ Path.d - [ MoveTo Absolute ( p.x, p.y ) - , VerticalLineTo Relative length - , HorizontalLineTo Relative lugWidth - , VerticalLineTo Relative -length - , ClosePath - ] - , fill "none" - , stroke "currentColor" - , strokeWidth (toMM params.rendering.lineWidth |> String.fromFloat) - , highlightStroke (highlighting == Just LugWidth || highlighting == Just ShortPieceLength) - ] - [] + shortPieceShape params + highlighting + { at = ( p.x, p.y ) + , includeCaseSideFlap = False + , includeClaspSideFlap = False + } }