diff --git a/playable.js b/playable.js index 8d42b67..5d3b0a9 100644 --- a/playable.js +++ b/playable.js @@ -1,9 +1,12 @@ // TODO clean changeVolume, use Tone.Draw +// pauseOffset = sound time after the start point = position of the animation in sound time +// startTime = date of the corresponding start = date of the last 0% of the animation +// startPercent = percent of the whole sound where to start + function prepare(model, rate = 1) { model.paused = true model.pauseOffset = 0 - model.length = model.length if (model.view && model.id) { model.view = SVG.adopt(document.getElementById(model.id)) /* model.once @@ -12,9 +15,9 @@ function prepare(model, rate = 1) { } if (model.soundName) { model.player = new Tone.Player(buffers[model.soundName]).toMaster() - setVolume(model) - model.duration = model.player.buffer.duration + model.duration = model.loopPoints[1] - model.loopPoints[0] model.player.playbackRate = model.rate = rate * model.duration / model.length + model.player.setLoopPoints.apply(model.player, model.loopPoints) model.player.loop = true } if (model.mobile) { @@ -27,11 +30,7 @@ function prepare(model, rate = 1) { model.rate = (rate * model.duration / model.length) || 1 // TODO when preparing top collar, no model.length model.durs = model.collar.beads.map(v => v.length / model.rate) let totalDur = model.durs.reduce((a,b) => a+b, 0) - model.players = model.collar.beads.map((v,i) => { - v.id = model.baseId + i -// v.once = true - return prepare(v, model.rate) - }) + model.players = model.collar.beads.map(v => prepare(v, model.rate)) model.clocks = model.players.map((subModel,i,a) => { return new Tone.Clock(t => { if (model.paused && (model.progPause <= t)) return; @@ -46,6 +45,7 @@ function prepare(model, rate = 1) { }, 1/totalDur) }) } + setVolume(model) return model } @@ -59,8 +59,7 @@ function play(model, t, newModel = {}, volume = 1, mute = false) { // TODO What Tone.Draw.schedule(() => model.view.animate().play(), t) } if (model.soundName && model.player.output) { - setVolume(model, volume, mute) - model.player.start(t, model.pauseOffset + (model.startPercent * model.length)) + model.player.start(t, model.pauseOffset + (model.startPercent * model.player.buffer.duration)) } if (model.mobile) { model.gears.map((v,i) => play(v, t, model.gears[i], model.volume * volume, model.mute || mute)) @@ -87,7 +86,7 @@ function play(model, t, newModel = {}, volume = 1, mute = false) { // TODO What function pause(model, t, force = false, clocked = false) { if (model.paused && !force) return; model.paused = true - model.pauseOffset = ((t - model.startTime) * model.rate) + model.pauseOffset = ((t - model.startTime) * model.rate) % model.duration if (model.view){//} && !clocked) { Tone.Draw.schedule(() => model.view.animate().pause().at((model.pauseOffset/model.length/model.rate) % 1), t) } @@ -121,8 +120,14 @@ function stop(model) { function setVolume(model, volume = 1, mute = false) { if (model.soundName) { - if (mute || model.mute) model.player.volume.value = -100000 - else model.player.volume.value = ((model.volume * volume) - 1) * 60 + if (mute || model.mute) { + model.player.toMaster() + model.player.disconnect(Tone.Master) + } + else { + model.player.toMaster() + model.player.volume.value = ((model.volume * volume) - 1) * 60 + } } if (model.mobile) model.gears.map(v => setVolume(v, model.volume * volume, model.mute || mute)) if (model.collar) model.players.map(v => setVolume(v, model.volume * volume, model.mute || mute)) diff --git a/src/Data/Common.elm b/src/Data/Common.elm index b48c249..893935a 100644 --- a/src/Data/Common.elm +++ b/src/Data/Common.elm @@ -19,19 +19,37 @@ type alias Identifier = getName : Identifier -> Mobile Wheel -> String getName ( id, l ) mobile = let - name = - (getWheel ( id, l ) mobile).name + w = + getWheel ( id, l ) mobile in - if String.isEmpty name then + if String.isEmpty w.name then case l of [] -> - Gear.toUID id + case Wheel.getWheelContent w of + Content.S s -> + let + fileName = + Sound.fileName s + in + if String.isEmpty fileName then + Gear.toUID id + + else + fileName + + _ -> + Gear.toUID id _ -> - "beadTODO" + toUid ( id, l ) else - name + w.name + + +toUid : Identifier -> String +toUid ( id, l ) = + List.foldl (\i uid -> Content.beadUIDExtension uid i) (Gear.toUID id) l getWheel : Identifier -> Mobile Wheel -> Wheel diff --git a/src/Data/Content.elm b/src/Data/Content.elm index 292e2d2..1f7adb6 100644 --- a/src/Data/Content.elm +++ b/src/Data/Content.elm @@ -74,6 +74,11 @@ mobileDecoder wheelDecoder defaultWheel = ) +beadUIDExtension : String -> Int -> String +beadUIDExtension parentUid i = + parentUid ++ "-" ++ String.fromInt i + + type alias Bead item = { length : Float, wheel : item } diff --git a/src/Data/Wheel.elm b/src/Data/Wheel.elm index 6d84e20..bda2486 100644 --- a/src/Data/Wheel.elm +++ b/src/Data/Wheel.elm @@ -21,12 +21,12 @@ type alias Wheeled a = type alias Wheel = { name : String - , startPercent : Float + , startPercent : Float -- Percent of whole sound, not just looped part , volume : Float , content : WheelContent , viewContent : Bool , mute : Bool - , color : Color + , color : Float } @@ -52,6 +52,16 @@ getWheelContent { content } = c +getLoopPercents : Wheeled g -> ( Float, Float ) +getLoopPercents { wheel } = + case wheel.content of + C (Content.S s) -> + Sound.getLoopPercents s + + _ -> + ( 0, 1 ) + + setContent : Conteet -> Wheeled g -> Wheeled g setContent c g = let @@ -69,7 +79,7 @@ default = , content = C <| Content.S Sound.noSound , viewContent = True , mute = False - , color = Color.black + , color = 0 } @@ -89,7 +99,7 @@ type alias Style = { mod : Mod , motor : Bool , dashed : Bool - , baseColor : Maybe Color + , baseColor : Maybe Float , named : Bool } @@ -110,8 +120,9 @@ type Msg | ToggleMute | Mute Bool | ChangeStart Float + | ChangeLoop ( Maybe Float, Maybe Float ) | Named String - | ChangeColor Color + | ChangeColor Float | ToggleContentView @@ -135,7 +146,37 @@ update msg g = { g | wheel = { wheel | mute = b } } ChangeStart percent -> - { g | wheel = { wheel | startPercent = percent } } + let + ( min, max ) = + case wheel.content of + C (Content.S s) -> + Sound.getLoopPercents s + + _ -> + ( 0, 1 ) + in + { g | wheel = { wheel | startPercent = clamp min max percent } } + + ChangeLoop mayPoints -> + case wheel.content of + C (Content.S s) -> + let + newSound = + Sound.setLoop mayPoints s + + ( min, max ) = + Sound.getLoopPercents newSound + in + { g + | wheel = + { wheel + | content = C <| Content.S newSound + , startPercent = clamp min max wheel.startPercent + } + } + + _ -> + g Named name -> if String.all (\c -> Char.isAlphaNum c || c == '-') name then @@ -186,6 +227,12 @@ view w pos lengthTmp style mayWheelInter mayHandleInter uid = circum = length * pi + ( loopStart, loopEnd ) = + getLoopPercents { wheel = w } + + tickPercent = + (w.startPercent - loopStart) / (loopEnd - loopStart) + ( hoverAttrs, dragAttrs ) = Maybe.withDefault ( [], [] ) <| Maybe.map @@ -202,11 +249,23 @@ view w pos lengthTmp style mayWheelInter mayHandleInter uid = , SA.stroke Color.white , SA.strokeWidth <| Num (tickW / 4) ] - [ text w.name ] + [ text <| + if String.isEmpty w.name then + case getWheelContent w of + Content.S s -> + Sound.fileName s + + _ -> + "" + + else + w.name + ] ] else - [] + [ S.text_ [] [] ] + -- Because rotating g cannot be Keyed in TypedSvg, trick to prevent recreation ) ++ [ S.g hoverAttrs <| ([ S.g @@ -247,9 +306,7 @@ view w pos lengthTmp style mayWheelInter mayHandleInter uid = [ SA.fill <| Fill Color.white ] else - [ SA.fill <| Fill w.color - , SA.fillOpacity <| Opacity (0.2 + 0.8 * w.volume) - ] + [ SA.fill <| Fill <| Color.hsl w.color 1 (0.85 - 0.35 * w.volume) ] ) ) [] @@ -258,7 +315,7 @@ view w pos lengthTmp style mayWheelInter mayHandleInter uid = , SA.height <| Num tickH , SA.x <| Num (tickW / -2) , SA.y <| Num (tickH / -2) - , SA.transform [ Rotate (w.startPercent * 360) 0 0, Translate 0 ((length / -2) - (tickH / 2)) ] + , SA.transform [ Rotate (tickPercent * 360) 0 0, Translate 0 ((length / -2) - (tickH / 2)) ] ] [] ] @@ -269,7 +326,7 @@ view w pos lengthTmp style mayWheelInter mayHandleInter uid = , SA.cy <| Num 0 , SA.r <| Num (length / 2 - tickW * 2.5) , SA.strokeWidth <| Num (tickW * 4) - , SA.stroke c + , SA.stroke <| Color.hsl c 1 0.5 , SA.fill FillNone ] [] @@ -278,67 +335,67 @@ view w pos lengthTmp style mayWheelInter mayHandleInter uid = Nothing -> [] ) - ++ (if viewContent then - case w.content of - C (Content.C collar) -> - let - scale = - lengthTmp / Content.getMatriceLength collar - in - [ S.g [ SA.transform [ Translate (-lengthTmp / 2) 0, Scale scale scale ] ] <| - insideCollarView collar mayWheelInter uid - ] + ) - _ -> - Debug.todo "view Sound or Mobile inside wheel" + -- end rotation drag + ] + -- No drag events part + ++ (if viewContent then + case w.content of + C (Content.C collar) -> + let + scale = + lengthTmp / Content.getMatriceLength collar + in + [ S.g [ SA.transform [ Translate (-lengthTmp / 2) 0, Scale scale scale ] ] <| + insideCollarView collar mayWheelInter uid + ] - else - let - symSize = - length / 4 - in - case w.content of - C (Content.M _) -> - [ S.line - [ SA.x1 <| Num -symSize - , SA.y1 <| Num -symSize - , SA.x2 <| Num symSize - , SA.y2 <| Num symSize - , SA.stroke Color.grey - , SA.strokeWidth <| Num tickW - ] - [] - , S.line - [ SA.x1 <| Num -symSize - , SA.y1 <| Num symSize - , SA.x2 <| Num symSize - , SA.y2 <| Num -symSize - , SA.stroke Color.grey - , SA.strokeWidth <| Num tickW - ] - [] + _ -> + Debug.todo "view Sound or Mobile inside wheel" + + else + let + symSize = + length / 4 + in + case w.content of + C (Content.M _) -> + [ S.line + [ SA.x1 <| Num -symSize + , SA.y1 <| Num -symSize + , SA.x2 <| Num symSize + , SA.y2 <| Num symSize + , SA.stroke Color.grey + , SA.strokeWidth <| Num tickW ] - - C (Content.C _) -> - [ S.line - [ SA.x1 <| Num -symSize - , SA.y1 <| Num 0 - , SA.x2 <| Num symSize - , SA.y2 <| Num 0 - , SA.stroke Color.grey - , SA.strokeWidth <| Num tickW - ] - [] + [] + , S.line + [ SA.x1 <| Num -symSize + , SA.y1 <| Num symSize + , SA.x2 <| Num symSize + , SA.y2 <| Num -symSize + , SA.stroke Color.grey + , SA.strokeWidth <| Num tickW ] + [] + ] - _ -> + C (Content.C _) -> + [ S.line + [ SA.x1 <| Num -symSize + , SA.y1 <| Num 0 + , SA.x2 <| Num symSize + , SA.y2 <| Num 0 + , SA.stroke Color.grey + , SA.strokeWidth <| Num tickW + ] [] - ) - ) + ] - -- end rotation drag - ] - -- No drag events part + _ -> + [] + ) ++ (case style.mod of Selected first -> [ S.circle @@ -410,10 +467,10 @@ insideCollarView collar mayWheelInter parentUid = ( view b.wheel (vec2 (p + b.length / 2) 0) b.length - defaultStyle + { defaultStyle | named = False } (Maybe.map (\( inter, l ) -> ( inter, l ++ [ i ] )) mayWheelInter) Nothing - (parentUid ++ String.fromInt i) + (Content.beadUIDExtension parentUid i) :: res , ( p + b.length , i + 1 @@ -430,7 +487,7 @@ encoder w = , ( "startPercent", E.float w.startPercent ) , ( "volume", E.float w.volume ) , ( "mute", E.bool w.mute ) - , ( "color", colorEncoder w.color ) + , ( "color", E.float w.color ) , ( "viewContent", E.bool w.viewContent ) , case w.content of C c -> @@ -453,42 +510,28 @@ decoder = \volume -> Field.require "mute" D.bool <| \mute -> - Field.attempt "color" colorDecoder <| - \color -> - D.succeed - { name = Maybe.withDefault "" name - , startPercent = startPercent - , volume = volume - , content = C content - , viewContent = Maybe.withDefault True viewContent - , mute = mute - , color = Maybe.withDefault Color.black color - } + Field.attempt "color" D.float <| + \mayColor -> + Field.attemptAt [ "color", "hue" ] D.float <| + \mayHue -> + D.succeed + { name = Maybe.withDefault "" name + , startPercent = startPercent + , volume = volume + , content = C content + , viewContent = Maybe.withDefault True viewContent + , mute = mute + , color = + case mayColor of + Just c -> + c + + Nothing -> + case mayHue of + Just h -> + h + + Nothing -> + 0 + } ) - - -colorEncoder : Color -> E.Value -colorEncoder c = - let - named = - Color.toHsla c - in - E.object - [ ( "hue", E.float named.hue ) - , ( "sat", E.float named.saturation ) - , ( "light", E.float named.lightness ) - , ( "alpha", E.float named.alpha ) - ] - - -colorDecoder : D.Decoder Color -colorDecoder = - Field.require "hue" D.float <| - \hue -> - Field.require "sat" D.float <| - \sat -> - Field.require "light" D.float <| - \light -> - Field.require "alpha" D.float <| - \alpha -> - D.succeed <| Color.hsla hue sat light alpha diff --git a/src/Doc.elm b/src/Doc.elm index 95b373e..96697ef 100644 --- a/src/Doc.elm +++ b/src/Doc.elm @@ -1,6 +1,5 @@ port module Doc exposing (..) -import Coll exposing (Coll, Id) import Data exposing (Data) import Data.Common as Common exposing (Identifier) import Data.Content as Content exposing (Content) @@ -34,7 +33,7 @@ init : Maybe Url -> Doc init url = { data = Data.init Mobile.new url , viewing = [] - , editor = Editor.init Nothing Nothing + , editor = Editor.init } @@ -92,7 +91,7 @@ update msg doc = New -> ( { data = Data.new Mobile.new doc.data , viewing = [] - , editor = Editor.init Nothing <| Just <| Editor.getShared doc.editor + , editor = Editor.changeView Nothing "" doc.editor } , toEngine Engine.stop ) @@ -100,7 +99,7 @@ update msg doc = Loaded m name -> ( { data = Data.load m name doc.data , viewing = [] - , editor = Editor.init (Just m) <| Just <| Editor.getShared doc.editor + , editor = Editor.changeView (Just m) "" doc.editor } , toEngine Engine.stop ) @@ -110,29 +109,41 @@ update msg doc = data = Data.undo doc.data - mayView = - Tuple.second <| getViewingCleaned doc.viewing <| Data.current data + ( mobile, ( viewUid, mayView ) ) = + getViewingCleaned doc.viewing <| Data.current data in - ( { doc | data = data, viewing = Maybe.withDefault doc.viewing mayView }, toEngine Engine.stop ) + ( { doc + | data = data + , viewing = Maybe.withDefault doc.viewing mayView + , editor = Editor.changeView (Just mobile) viewUid doc.editor + } + , toEngine Engine.stop + ) Redo -> let data = Data.redo doc.data - mayView = - Tuple.second <| getViewingCleaned doc.viewing <| Data.current data + ( mobile, ( viewUid, mayView ) ) = + getViewingCleaned doc.viewing <| Data.current data in - ( { doc | data = data, viewing = Maybe.withDefault doc.viewing mayView }, toEngine Engine.stop ) + ( { doc + | data = data + , viewing = Maybe.withDefault doc.viewing mayView + , editor = Editor.changeView (Just mobile) viewUid doc.editor + } + , toEngine Engine.stop + ) View l -> let - ( mobile, mayView ) = + ( mobile, ( viewUid, mayView ) ) = getViewingCleaned l <| Data.current doc.data in ( { doc | viewing = Maybe.withDefault l mayView - , editor = Editor.init (Just mobile) <| Just <| Editor.getShared doc.editor + , editor = Editor.changeView (Just mobile) viewUid doc.editor } , toEngine Engine.stop ) @@ -154,17 +165,28 @@ update msg doc = update (MobileMsg <| Editor.ChangedTool <| Editor.Harmonize) doc 3 -> - update (MobileMsg <| Editor.ChangedTool <| Editor.Edit) doc + update (MobileMsg <| Editor.ChangedTool <| Editor.Edit False) doc _ -> ( doc, Cmd.none ) Play -> - update (MobileMsg <| Editor.ToggleEngine) doc + case doc.editor.tool of + Editor.Play _ _ -> + update (MobileMsg <| Editor.ToggleEngine) doc + + Editor.Edit True -> + update (MobileMsg <| Editor.StopGear) doc + + Editor.Edit False -> + update (MobileMsg <| Editor.PlayGear) doc + + _ -> + ( doc, Cmd.none ) Suppr -> case ( doc.editor.edit, doc.editor.tool ) of - ( [ id ], Editor.Edit ) -> + ( [ id ], Editor.Edit _ ) -> update (MobileMsg <| Editor.DeleteWheel ( id, [] )) doc _ -> @@ -209,15 +231,23 @@ update msg doc = ++ [ ( Common.getName id mobile, id ) ] ) newDoc + + Editor.UnSolo -> + ( newDoc + , Cmd.batch <| + List.map toEngine <| + Editor.updateAllMuteToEngine newDoc.editor <| + Data.current newDoc.data + ) ) ) in ( finalDoc - , Cmd.batch + , Cmd.batch <| [ Cmd.map MobileMsg res.cmd - , Maybe.withDefault Cmd.none <| Maybe.map toEngine res.toEngine , cmd ] + ++ List.map toEngine res.toEngine ) InteractMsg subMsg -> @@ -346,23 +376,23 @@ getViewing { viewing, data } = -- TODO Should be able to check id and indexes existence to clean, do it if Common.getWheel? Or make a copy here -getViewingCleaned : List ( String, Identifier ) -> Mobeel -> ( Mobeel, Maybe (List ( String, Identifier )) ) +getViewingCleaned : List ( String, Identifier ) -> Mobeel -> ( Mobeel, ( String, Maybe (List ( String, Identifier )) ) ) getViewingCleaned l mobile = case l of ( str, next ) :: rest -> case Wheel.getWheelContent <| Common.getWheel next mobile of Content.M m -> let - ( mob, may ) = + ( mob, ( parentUid, may ) ) = getViewingCleaned rest m in - ( mob, Maybe.map ((::) ( str, next )) may ) + ( mob, ( Common.toUid next, Maybe.map ((::) ( str, next )) may ) ) _ -> - Debug.log ("No mobile to view in " ++ str) ( mobile, Just [] ) + Debug.log ("No mobile to view in " ++ str) ( mobile, ( "", Just [] ) ) _ -> - ( mobile, Nothing ) + ( mobile, ( "", Nothing ) ) updateViewing : List ( String, Identifier ) -> (Mobeel -> Mobeel) -> Mobeel -> Mobeel diff --git a/src/Editor/Interacting.elm b/src/Editor/Interacting.elm index 8f21625..fadbebd 100644 --- a/src/Editor/Interacting.elm +++ b/src/Editor/Interacting.elm @@ -16,8 +16,17 @@ type Interactable | IPacked (Id Packed) | ILink (Link Geer) | ISound Sound + | IWaveCursor Cursor + | IWaveSel type Zone = ZSurface | ZPack + | ZWave + + +type Cursor + = LoopStart + | LoopEnd + | StartOffset diff --git a/src/Editor/Mobile.elm b/src/Editor/Mobile.elm index 0a45735..0f351b3 100644 --- a/src/Editor/Mobile.elm +++ b/src/Editor/Mobile.elm @@ -9,7 +9,7 @@ import Data.Gear as Gear import Data.Mobile as Mobile exposing (Geer, Mobeel) import Data.Wheel as Wheel exposing (Conteet, Wheel) import Dict -import Editor.Interacting exposing (Interactable(..), Zone(..)) +import Editor.Interacting exposing (..) import Element exposing (..) import Element.Background as Bg import Element.Border as Border @@ -73,10 +73,11 @@ type alias Model = , edit : List (Id Geer) , cursor : Int , link : Maybe LinkInfo + , parentUid : String -- TODO Two sources of truth !! same in Engine , engine : Engine , interact : Interact.State Interactable Zone , pack : Pack - , wave : ( Waveform, Maybe Sound ) -- TODO Second source of truth with edit? Could be just Bool + , wave : Waveform , svg : PanSvg.Model } @@ -91,7 +92,7 @@ defaultAddPos = type Tool - = Edit + = Edit Bool -- Playing | Play Bool Bool -- Playing, Recording | Harmonize @@ -137,6 +138,7 @@ type Dragging | SizeChange | Moving | Packing + | Waving | Packed Vec2 (Id Packed) | Content ( Vec2, Float ) | ChgContent (Id Geer) Dragging @@ -146,32 +148,37 @@ type alias BlinkState = ( Bool, Float ) -getShared : Model -> ( Pack, PanSvg.Model ) -getShared { pack, svg } = - ( pack, svg ) - - -init : Maybe Mobeel -> Maybe ( Pack, PanSvg.Model ) -> Model -init mayMobile mayShared = - let - base = - Maybe.withDefault (PanSvg.init svgId) <| Maybe.map Tuple.second mayShared - - svg = - Maybe.withDefault base <| - Maybe.map (\m -> PanSvg.centerZoom (Mobile.gearPosSize m.motor m.gears) base) mayMobile - in +init : Model +init = { dragging = NoDrag , tool = Play False False , mode = Normal , edit = [] , cursor = 0 , link = Nothing + , parentUid = "" , engine = Engine.init , interact = Interact.init - , pack = Pack.update (Pack.PrepareZoom svg) <| Maybe.withDefault Pack.init <| Maybe.map Tuple.first mayShared - , wave = ( Waveform.init, Nothing ) - , svg = svg + , pack = Pack.init + , wave = Waveform.init + , svg = PanSvg.init svgId + } + + +changeView : Maybe Mobeel -> String -> Model -> Model +changeView mayMobile parentUid model = + let + svg = + Maybe.withDefault (PanSvg.init svgId) <| + Maybe.map (\m -> PanSvg.centerZoom (Mobile.gearPosSize m.motor m.gears) model.svg) mayMobile + in + { model + | edit = [] + , link = Nothing + , engine = Engine.setParentUid parentUid Engine.init + , parentUid = parentUid + , svg = svg + , pack = Pack.update (Pack.PrepareZoom svg) model.pack } @@ -180,8 +187,8 @@ type Msg | ChangedMode Mode -- TODO EngineMsg ? | ToggleEngine - | PlayGear (Id Geer) - | StopGear (Id Geer) + | PlayGear + | StopGear | ToggleRecord Bool | GotRecord (Result D.Error String) -- COLLAR EDIT @@ -219,7 +226,7 @@ type alias Return = { model : Model , mobile : Mobeel , toUndo : ToUndo - , toEngine : Maybe E.Value + , toEngine : List E.Value , outMsg : Maybe DocMsg , cmd : Cmd Msg } @@ -227,6 +234,7 @@ type alias Return = type DocMsg = Inside Identifier + | UnSolo type ToUndo @@ -243,7 +251,7 @@ update msg ( model, mobile ) = { model = model , mobile = mobile , toUndo = NOOP - , toEngine = Nothing + , toEngine = [] , outMsg = Nothing , cmd = Cmd.none } @@ -260,18 +268,23 @@ update msg ( model, mobile ) = NoDrag _ -> - if tool == Edit then - NoDrag + case tool of + Edit _ -> + NoDrag - else - model.dragging + _ -> + model.dragging , engine = Engine.init } - , toEngine = Just Engine.stop + , toEngine = [ Engine.stop ] } ChangedMode mode -> - { return | model = { model | mode = mode } } + if model.mode == Solo && mode /= Solo then + { return | model = { model | mode = mode }, toUndo = Cancel, outMsg = Just UnSolo } + + else + { return | model = { model | mode = mode } } ToggleEngine -> if Coll.maybeGet mobile.motor mobile.gears == Nothing then @@ -282,7 +295,7 @@ update msg ( model, mobile ) = Play True r -> { return | model = { model | tool = Play False r, engine = Engine.init } - , toEngine = Just Engine.stop + , toEngine = [ Engine.stop ] } Play False r -> @@ -314,15 +327,25 @@ update msg ( model, mobile ) = Err err -> Debug.log (D.errorToString err) return - PlayGear id -> - let - ( engine, v ) = - Engine.addPlaying [ id ] mobile.gears model.engine - in - { return | model = { model | engine = engine }, toEngine = v } + PlayGear -> + case model.tool of + Edit _ -> + let + ( engine, v ) = + Engine.addPlaying model.edit mobile.gears model.engine + in + { return | model = { model | engine = engine, tool = Edit True }, toEngine = v } + + _ -> + return + + StopGear -> + case model.tool of + Edit _ -> + { return | model = { model | engine = Engine.init, tool = Edit False }, toEngine = [ Engine.stop ] } - StopGear id -> - { return | model = { model | engine = Engine.init }, toEngine = Just Engine.stop } + _ -> + return CursorRight -> case model.edit of @@ -461,7 +484,7 @@ update msg ( model, mobile ) = , engine = Engine.init } , toUndo = Do - , toEngine = Just Engine.stop + , toEngine = [ Engine.stop ] , mobile = CommonData.deleteWheel ( id, l ) mobile Mobile.rm Collar.rm } @@ -780,14 +803,14 @@ update msg ( model, mobile ) = Result.Ok s -> let ( wave, cmd ) = - Waveform.update (Waveform.GotSize <| floor s.width) <| Tuple.first model.wave + Waveform.update (Waveform.GotSize <| floor s.width) model.wave in { return | model = { model | svg = PanSvg.update (PanSvg.ScaleSize 1 s) model.svg , pack = Pack.update (Pack.SvgMsg <| PanSvg.ScaleSize model.pack.scale s) model.pack - , wave = Tuple.mapFirst (always wave) model.wave + , wave = wave } , cmd = Cmd.map WaveMsg cmd } @@ -798,9 +821,9 @@ update msg ( model, mobile ) = WaveMsg subMsg -> let ( wave, cmd ) = - Waveform.update subMsg <| Tuple.first model.wave + Waveform.update subMsg model.wave in - { return | model = { model | wave = Tuple.mapFirst (always wave) model.wave }, cmd = Cmd.map WaveMsg cmd } + { return | model = { model | wave = wave }, cmd = Cmd.map WaveMsg cmd } -- TODO use some pattern like outMessage package? or elm-state? elm-return? -- TODO move all that in Editor.Interacting, and manage then @@ -831,6 +854,9 @@ update msg ( model, mobile ) = ZPack -> newModel.pack.svg + _ -> + Debug.todo "No pos map if Zone isn’t SVG" + toInPos z p = PanSvg.mapIn p <| svgFromZone z @@ -839,20 +865,24 @@ update msg ( model, mobile ) = Interact.Dragged info dragZone k -> let startZone = - Tuple.second info.init + Tuple.second info.start in - { e - | action = - Interact.Dragged - { info - | init = Tuple.mapFirst (toInPos <| Tuple.second info.init) info.init - , oldPos = toInPos dragZone info.oldPos - , newPos = toInPos dragZone info.newPos - , startD = Vec.scale (PanSvg.getScale <| svgFromZone <| Tuple.second info.init) info.startD - } - dragZone - k - } + if startZone == ZWave || dragZone == ZWave then + e + + else + { e + | action = + Interact.Dragged + { info + | start = Tuple.mapFirst (toInPos startZone) info.start + , oldPos = toInPos dragZone info.oldPos + , newPos = toInPos dragZone info.newPos + , startD = Vec.scale (PanSvg.getScale <| svgFromZone startZone) info.startD + } + dragZone + k + } _ -> e @@ -882,7 +912,7 @@ viewTools model = , options = [ Input.option (Play False False) <| text "Jeu (W)" , Input.option Harmonize <| text "Harmonie (X)" - , Input.option Edit <| text "Édition (C)" + , Input.option (Edit False) <| text "Édition (C)" ] , selected = Just model.tool , label = Input.labelHidden "Outils" @@ -922,6 +952,28 @@ viewExtraTools model = } ] + Edit play -> + if not <| List.isEmpty model.edit then + [ Input.button [ centerX ] + { label = + if play then + text "Stop" + + else + text "Entendre" + , onPress = + Just <| + if play then + StopGear + + else + PlayGear + } + ] + + else + [] + _ -> [] ) @@ -934,35 +986,39 @@ viewExtraTools model = viewContent : ( Model, Mobeel ) -> Element Msg viewContent ( model, mobile ) = let - ( wavePercent, percentMsg, viewContentEdit ) = + ( wavePoints, viewWave ) = case model.edit of [ id ] -> - ( (Coll.get id mobile.gears).wheel.startPercent - , \f -> WheelMsgs [ ( ( id, [] ), Wheel.ChangeStart f ) ] - , (Coll.get id mobile.gears).wheel.viewContent - ) + let + g = + Coll.get id mobile.gears - _ -> - ( 0, always NoMsg, False ) + ( start, end ) = + Wheel.getLoopPercents g + in + ( { offset = g.wheel.startPercent, start = start, end = end } + , case ( model.tool, Wheel.getContent g ) of + ( Edit _, Content.S s ) -> + (model.wave.drawn == (Waveform.SoundDrawn <| Sound.toString s)) + && g.wheel.viewContent - viewWave = - case ( Tuple.second model.wave, (Tuple.first model.wave).drawn ) of - ( Just s1, Waveform.SoundDrawn s2 ) -> - s1 == s2 && model.tool == Edit && viewContentEdit + _ -> + False + ) _ -> - False + ( { offset = 0, start = 0, end = 0 }, False ) getMod : Id Geer -> Wheel.Mod getMod id = - if model.tool == Edit && List.member id model.edit then + if (model.tool == Edit False || model.tool == Edit True) && List.member id model.edit then Wheel.Selected <| (List.length model.edit > 1) && ((List.head <| List.reverse model.edit) == Just id) else case Interact.getInteract model.interact of - Just ( IWheel ( iid, [] ), mode ) -> + Just ( IWheel ( iid, _ ), mode ) -> if iid /= id then Wheel.None @@ -971,7 +1027,7 @@ viewContent ( model, mobile ) = ( Harmonize, Interact.Hover ) -> Wheel.Resizing - ( Edit, Interact.Hover ) -> + ( Edit _, Interact.Hover ) -> Wheel.Selectable _ -> @@ -1018,7 +1074,13 @@ viewContent ( model, mobile ) = IPacked IPack InteractMsg - , Element.inFront <| Waveform.view viewWave (Tuple.first model.wave) wavePercent percentMsg + , Element.inFront <| + Waveform.view + viewWave + model.wave + wavePoints + model.interact + InteractMsg ] <| Element.html <| @@ -1078,7 +1140,7 @@ viewContent ( model, mobile ) = } (Just ( IWheel << Tuple.pair id, [] )) (Just <| IResizeHandle id) - (Gear.toUID id) + (model.parentUid ++ Gear.toUID id) ) <| Coll.toList mobile.gears @@ -1103,6 +1165,20 @@ viewContent ( model, mobile ) = (Harmo.getLength g.harmony mobile.gears) Link.baseColor ] + ++ [ S.g [ SA.opacity <| Opacity 0 ] <| + List.map + (\( idd, gg ) -> + Wheel.view gg.wheel + gg.pos + (Harmo.getLength gg.harmony mobile.gears) + Wheel.defaultStyle + (Just ( IWheel << Tuple.pair idd, [] )) + Nothing + ("hoverArtefact-" ++ Gear.toUID idd) + ) + <| + Coll.toList mobile.gears + ] _ -> [] @@ -1197,7 +1273,7 @@ viewContent ( model, mobile ) = [] ) - Edit -> + Edit _ -> case model.edit of [ id ] -> let @@ -1306,7 +1382,7 @@ viewDetails model mobile = _ -> case model.tool of - Edit -> + Edit _ -> viewEditDetails model mobile Harmonize -> @@ -1331,7 +1407,7 @@ viewEditDetails model mobile = [ Input.text [ Font.color (rgb 0 0 0) ] { label = Input.labelAbove [] <| text "Roue :" , text = g.wheel.name - , placeholder = Just <| Input.placeholder [] <| text <| Gear.toUID id + , placeholder = Just <| Input.placeholder [] <| text <| CommonData.getName ( id, [] ) mobile , onChange = \str -> WheelMsgs [ ( wId, Wheel.Named str ) ] } , case Wheel.getContent g of @@ -1476,18 +1552,20 @@ viewEditDetails model mobile = , html <| Html.input [ Html.Attributes.type_ "color" - , Html.Attributes.value <| colorToString g.wheel.color + , Html.Attributes.value <| colorToString <| Color.hsl g.wheel.color 1 0.5 , Html.Events.onInput (\str -> WheelMsgs [ ( wId , Wheel.ChangeColor <| - Color.fromRgba - { red = hexToFloat <| String.slice 1 3 str - , green = hexToFloat <| String.slice 3 5 str - , blue = hexToFloat <| String.slice 5 7 str - , alpha = 1 - } + (Color.toHsla <| + Color.fromRgba + { red = hexToFloat <| String.slice 1 3 str + , green = hexToFloat <| String.slice 3 5 str + , blue = hexToFloat <| String.slice 5 7 str + , alpha = 1 + } + ).hue ) ] ) @@ -1639,7 +1717,7 @@ doVolumeChange : -> Vec2 -> Mobeel -> Engine - -> { mobile : Mobeel, toUndo : ToUndo, toEngine : Maybe E.Value } + -> { mobile : Mobeel, toUndo : ToUndo, toEngine : List E.Value } doVolumeChange id absD mobile engine = let volume = @@ -1673,14 +1751,14 @@ doResize id d add mobile = { mobile | gears = Harmo.resizeFree id newSize gears } -doChangeContent : Id Geer -> Conteet -> Maybe Color.Color -> Model -> Mobeel -> Return +doChangeContent : Id Geer -> Conteet -> Maybe Float -> Model -> Mobeel -> Return doChangeContent id c mayColor model mobile = let return = { model = model , mobile = mobile , toUndo = NOOP - , toEngine = Nothing + , toEngine = [] , outMsg = Nothing , cmd = Cmd.none } @@ -1695,6 +1773,7 @@ doChangeContent id c mayColor model mobile = List.foldl (\el -> Coll.update el chSound) mobile.gears group newModel = + -- TODO Why !!?? { model | mode = Normal } in case mayColor of @@ -1739,7 +1818,7 @@ manageInteractEvent event model mobile = { model = model , mobile = mobile , toUndo = NOOP - , toEngine = Nothing + , toEngine = [] , outMsg = Nothing , cmd = Cmd.none } @@ -1762,7 +1841,7 @@ manageInteractEvent event model mobile = Move -> case interactMove event model mobile of Just ret -> - { return | model = ret.model, mobile = ret.mobile, toUndo = ret.toUndo } + ret _ -> case ( event.item, event.action ) of @@ -1810,18 +1889,25 @@ manageInteractEvent event model mobile = case ( event.item, event.action ) of ( IWheel ( id, [] ), Interact.Holded ) -> -- TODO should work also for beads (not []), Mobile.mapWheels ? - { return - | mobile = + let + newMobile = List.foldl (\( idd, g ) -> CommonData.updateWheel ( idd, [] ) <| (Wheel.Mute <| idd /= id)) mobile <| Coll.toList mobile.gears + in + { return + | mobile = newMobile , toUndo = Group + , toEngine = updateAllMuteToEngine model newMobile } - ( IWheel ( id, [] ), Interact.HoldEnded ) -> - { return | toUndo = Cancel } + ( _, Interact.HoldEnded ) -> + { return | toUndo = Cancel, outMsg = Just UnSolo } + + ( _, Interact.DragEnded _ ) -> + { return | toUndo = Cancel, outMsg = Just UnSolo } _ -> return @@ -1848,14 +1934,23 @@ manageInteractEvent event model mobile = } ( _, Interact.DragEnded True, Alterning id1 (Just id2) _ ) -> - { return - | model = { model | dragging = NoDrag } - , mobile = + let + newMobile = List.foldl (\id mob -> CommonData.updateWheel id Wheel.ToggleMute mob) mobile [ id1, id2 ] + in + { return + | model = { model | dragging = NoDrag } + , mobile = newMobile , toUndo = Do + , toEngine = + List.concatMap + (\id -> + Engine.muted id (CommonData.getWheel id newMobile).mute model.engine + ) + [ id1, id2 ] } ( _, Interact.DragEnded _, _ ) -> @@ -1875,11 +1970,12 @@ manageInteractEvent event model mobile = [ id ] -> case Wheel.getWheelContent <| CommonData.getWheel ( id, [] ) mobile of Content.C _ -> - if model.tool == Edit then - update (NewBead <| Content.S s) ( model, mobile ) + case model.tool of + Edit _ -> + update (NewBead <| Content.S s) ( model, mobile ) - else - update (NewGear defaultAddPos <| Content.S s) ( model, mobile ) + _ -> + update (NewGear defaultAddPos <| Content.S s) ( model, mobile ) _ -> update (NewGear defaultAddPos <| Content.S s) ( model, mobile ) @@ -1901,15 +1997,16 @@ manageInteractEvent event model mobile = [ id ] -> case Wheel.getWheelContent <| CommonData.getWheel ( id, [] ) mobile of Content.C _ -> - if model.tool == Edit then - let - p = - Coll.get pId model.pack.wheels - in - update (UnpackBead ( p.wheel, p.length ) True) ( model, mobile ) + case model.tool of + Edit _ -> + let + p = + Coll.get pId model.pack.wheels + in + update (UnpackBead ( p.wheel, p.length ) True) ( model, mobile ) - else - return + _ -> + return _ -> return @@ -1961,17 +2058,36 @@ manageInteractEvent event model mobile = interactHarmonize event model mobile -- EDIT -------- - Edit -> + Edit _ -> case interactMove event model mobile of Just ret -> - { return | model = ret.model, mobile = ret.mobile, toUndo = ret.toUndo } + ret - _ -> - let - ( newModel, cmd ) = - interactSelectEdit event mobile model - in - { return | model = newModel, cmd = cmd } + Nothing -> + case interactSelectEdit event mobile model of + Just ( newModel, cmd ) -> + let + ret = + update StopGear ( newModel, mobile ) + in + { ret | cmd = Cmd.batch [ cmd, ret.cmd ] } + + Nothing -> + case model.edit of + [ id ] -> + let + g = + Coll.get id mobile.gears + in + case interactWave g event model mobile of + Just subMsg -> + update (WheelMsgs [ ( ( id, [] ), subMsg ) ]) ( model, mobile ) + + Nothing -> + return + + _ -> + return interactPlay : Bool -> Interact.Event Interactable Zone -> Model -> Mobeel -> Return @@ -1981,7 +2097,7 @@ interactPlay on event model mobile = { model = model , mobile = mobile , toUndo = NOOP - , toEngine = Nothing + , toEngine = [] , outMsg = Nothing , cmd = Cmd.none } @@ -2092,7 +2208,7 @@ interactHarmonize event model mobile = { model = model , mobile = mobile , toUndo = NOOP - , toEngine = Nothing + , toEngine = [] , outMsg = Nothing , cmd = Cmd.none } @@ -2162,83 +2278,254 @@ interactHarmonize event model mobile = return -interactSelectEdit : Interact.Event Interactable Zone -> Mobeel -> Model -> ( Model, Cmd Msg ) +interactSelectEdit : Interact.Event Interactable Zone -> Mobeel -> Model -> Maybe ( Model, Cmd Msg ) interactSelectEdit event mobile model = case ( event.item, event.action ) of ( IWheel ( id, _ ), Interact.Clicked ( _, False, False ) ) -> - case Wheel.getContent <| Coll.get id mobile.gears of - Content.S s -> - let - ( wave, cmd ) = - Waveform.update (Waveform.ChgSound s) <| Tuple.first model.wave - in - ( { model | edit = [ id ], wave = ( wave, Just s ) }, Cmd.map WaveMsg cmd ) + if model.edit == [ id ] then + Just ( { model | edit = [] }, Cmd.none ) - _ -> - ( { model | edit = [ id ], wave = Tuple.mapSecond (always Nothing) model.wave }, Cmd.none ) + else + case Wheel.getContent <| Coll.get id mobile.gears of + Content.S s -> + let + ( wave, cmd ) = + Waveform.update (Waveform.ChgSound <| Sound.toString s) model.wave + in + Just ( { model | edit = [ id ], wave = wave }, Cmd.map WaveMsg cmd ) + + Content.C _ -> + Just ( { model | edit = [ id ], cursor = 0 }, Cmd.none ) + + _ -> + Just ( { model | edit = [ id ] }, Cmd.none ) ( IWheel ( id, _ ), Interact.Clicked _ ) -> - ( { model | edit = id :: model.edit }, Cmd.none ) + let + already = + List.foldl (\el -> (||) <| el == id) False model.edit + in + Just + ( { model + | edit = + if already then + List.filter ((/=) id) model.edit + + else + id :: model.edit + } + , Cmd.none + ) _ -> - ( model, Cmd.none ) + Nothing interactMove : Interact.Event Interactable Zone -> Model -> Mobeel - -> Maybe { model : Model, mobile : Mobeel, toUndo : ToUndo } + -> Maybe Return interactMove event model mobile = + let + return = + { model = model + , mobile = mobile + , toUndo = NOOP + , cmd = Cmd.none + , toEngine = [] + , outMsg = Nothing + } + in case ( event.item, event.action, model.dragging ) of ( IWheel ( id, [] ), Interact.Dragged { newPos } ZSurface _, _ ) -> let gearUp = Gear.update <| Gear.NewPos newPos + + ( wave, cmd ) = + Waveform.update Waveform.CancelSel model.wave in Just - { model = { model | dragging = Moving, pack = Pack.update (Pack.DragTo Nothing) model.pack } - , mobile = { mobile | gears = Coll.update id gearUp mobile.gears } - , toUndo = Group + { return + | model = + { model + | dragging = Moving + , pack = Pack.update (Pack.DragTo Nothing) model.pack + , wave = wave + } + , mobile = { mobile | gears = Coll.update id gearUp mobile.gears } + , toUndo = Group + , cmd = Cmd.map WaveMsg cmd } ( _, Interact.DragEnded _, Moving ) -> - Just { model = { model | dragging = NoDrag }, mobile = mobile, toUndo = Do } + Just { return | model = { model | dragging = NoDrag }, mobile = mobile, toUndo = Do } ( IWheel ( id, [] ), Interact.Dragged { newPos } ZPack _, _ ) -> Just - { mobile = mobile - , toUndo = Cancel - , model = - { model - | dragging = Packing - , pack = - Pack.update - (Pack.DragTo <| - Just - { pos = newPos - , length = Harmo.getLengthId id mobile.gears - , wheel = (Coll.get id mobile.gears).wheel - } - ) - model.pack - } + { return + | toUndo = Cancel + , model = + { model + | dragging = Packing + , pack = + Pack.update + (Pack.DragTo <| + Just + { pos = newPos + , length = Harmo.getLengthId id mobile.gears + , wheel = (Coll.get id mobile.gears).wheel + } + ) + model.pack + } } ( IWheel ( id, [] ), Interact.DragEnded True, Packing ) -> Just - { mobile = mobile - , toUndo = Cancel - , model = { model | dragging = NoDrag, pack = Pack.update Pack.PackIt model.pack } + { return + | model = { model | dragging = NoDrag, pack = Pack.update Pack.PackIt model.pack } } + ( IWheel _, Interact.Dragged { absD } ZWave _, Waving ) -> + let + ( wave, cmd ) = + Waveform.update (Waveform.MoveSel <| Vec.getX absD) model.wave + in + Just + { return + | toUndo = Cancel + , model = { model | wave = wave } + , cmd = Cmd.map WaveMsg cmd + } + + ( IWheel ( id, [] ), Interact.Dragged { oldPos } ZWave _, _ ) -> + case model.edit of + [ waveId ] -> + let + waveG = + Coll.get waveId mobile.gears + + ( start, end ) = + Wheel.getLoopPercents waveG + + selPercentLength = + Harmo.getLengthId id mobile.gears * (end - start) / Harmo.getLength waveG.harmony mobile.gears + + ( wave, cmd ) = + Waveform.update (Waveform.Select ( Vec.getX oldPos, selPercentLength )) model.wave + in + Just + { return + | toUndo = Cancel + , model = + { model + | dragging = Waving + , wave = wave + } + , cmd = Cmd.map WaveMsg cmd + } + + _ -> + Nothing + + ( IWheel ( id, [] ), Interact.DragEnded True, Waving ) -> + case model.edit of + [ waveId ] -> + let + waveG = + Coll.get waveId mobile.gears + + waveW = + waveG.wheel + + mayLoop = + Waveform.getSelPercents model.wave + in + case ( mayLoop, Wheel.getWheelContent waveW ) of + ( Just ( start, end ), Content.S s ) -> + let + ( wave, cmd ) = + Waveform.update Waveform.CancelSel model.wave + + ret = + doChangeContent + id + (Content.S <| Sound.setLoop ( Just start, Just end ) s) + Nothing + model + mobile + + newModel = + ret.model + + newMobile = + ret.mobile + in + Just + { ret + | model = { newModel | dragging = NoDrag, wave = wave, edit = [ id ] } + , mobile = CommonData.updateWheel ( id, [] ) (Wheel.ChangeStart start) newMobile + , cmd = Cmd.batch [ ret.cmd, Cmd.map WaveMsg cmd ] + } + + _ -> + Nothing + + _ -> + Nothing + + _ -> + Nothing + + +interactWave : Geer -> Interact.Event Interactable Zone -> Model -> Mobeel -> Maybe Wheel.Msg +interactWave g event model mobile = + let + move d val = + val + (Vec.getX d / toFloat model.wave.size) + in + case ( event.item, event.action ) of + ( IWaveCursor cur, Interact.Dragged { absD } _ _ ) -> + case cur of + LoopEnd -> + Just <| + Wheel.ChangeLoop + ( Nothing + , Just <| move absD <| Tuple.second <| Wheel.getLoopPercents g + ) + + LoopStart -> + Just <| + Wheel.ChangeLoop + ( Just <| move absD <| Tuple.first <| Wheel.getLoopPercents g + , Nothing + ) + + StartOffset -> + Just <| Wheel.ChangeStart <| move absD <| g.wheel.startPercent + + ( IWaveSel, Interact.Dragged { absD } _ _ ) -> + let + mv = + Just << move absD + in + Just <| Wheel.ChangeLoop <| Tuple.mapBoth mv mv <| Wheel.getLoopPercents g + _ -> Nothing -colorGen : Random.Generator Color.Color +updateAllMuteToEngine : Model -> Mobeel -> List E.Value +updateAllMuteToEngine model mobile = + List.concatMap (\( idd, g ) -> Engine.muted ( idd, [] ) g.wheel.mute model.engine) <| + Coll.toList mobile.gears + + +colorGen : Random.Generator Float colorGen = - Random.map (\f -> Color.hsl f 1 0.5) <| Random.float 0 1 + Random.float 0 1 colorToString : Color.Color -> String diff --git a/src/Engine.elm b/src/Engine.elm index 5f63d17..dc1e37d 100644 --- a/src/Engine.elm +++ b/src/Engine.elm @@ -2,9 +2,9 @@ module Engine exposing ( Engine , addPlaying , init - , isPlaying , muted , playingIds + , setParentUid , setPlaying , stop , volumeChanged @@ -24,51 +24,53 @@ import Sound type Engine - = E (List (Id Geer)) + = E { playing : List (Id Geer), parentUid : String } init : Engine init = - E [] + E { playing = [], parentUid = "" } -isPlaying : Id Geer -> Engine -> Bool -isPlaying id (E l) = - List.member id l +setParentUid : String -> Engine -> Engine +setParentUid str (E e) = + E { e | parentUid = str } -playingIds : Engine -> List (Id Geer) -playingIds (E e) = - e +playingIds : + Engine + -> List (Id Geer) -- Needed to compute which needs to be paused or stopped in motor, when cut +playingIds (E { playing }) = + playing -setPlaying : List (Id Geer) -> Coll Geer -> Engine -> ( Engine, Maybe E.Value ) +setPlaying : List (Id Geer) -> Coll Geer -> Engine -> ( Engine, List E.Value ) setPlaying l coll (E e) = - ( E l + ( E { e | playing = l } , if List.isEmpty l then - Nothing + [] else - Just <| playPause coll <| List.filter (\el -> not <| List.member el l) e + [ playPause e.parentUid coll <| List.filter (\el -> not <| List.member el l) e.playing ] ) -addPlaying : List (Id Geer) -> Coll Geer -> Engine -> ( Engine, Maybe E.Value ) +addPlaying : List (Id Geer) -> Coll Geer -> Engine -> ( Engine, List E.Value ) addPlaying l coll (E e) = - ( E (e ++ l) + ( E { e | playing = e.playing ++ l } , if List.isEmpty l then - Nothing + [] else - Just <| playPause coll l + [ playPause e.parentUid coll l ] ) -playPause : Coll Geer -> List (Id Geer) -> E.Value -playPause coll els = +playPause : String -> Coll Geer -> List (Id Geer) -> E.Value +playPause parentUid coll els = E.object [ ( "action", E.string "playPause" ) - , ( "gears", E.list (encodeGear True coll) els ) + , ( "gears", E.list (encodeGear True parentUid coll) els ) ] @@ -77,38 +79,30 @@ stop = E.object [ ( "action", E.string "stopReset" ) ] -muted : Identifier -> Bool -> Engine -> Maybe E.Value -muted ( id, list ) mute e = - if isPlaying id e then - Just <| - E.object - [ ( "action", E.string "mute" ) - , ( "id", E.string <| Gear.toUID id ) - , ( "beadIndexes", E.list E.int list ) - , ( "value", E.bool mute ) - ] - - else - Nothing - +muted : Identifier -> Bool -> Engine -> List E.Value +muted ( id, list ) mute (E e) = + [ E.object + [ ( "action", E.string "mute" ) + , ( "id", E.string <| e.parentUid ++ Gear.toUID id ) + , ( "beadIndexes", E.list E.int list ) + , ( "value", E.bool mute ) + ] + ] -volumeChanged : Identifier -> Float -> Engine -> Maybe E.Value -volumeChanged ( id, list ) volume e = - if isPlaying id e then - Just <| - E.object - [ ( "action", E.string "volume" ) - , ( "id", E.string <| Gear.toUID id ) - , ( "beadIndexes", E.list E.int list ) - , ( "value", E.float <| clamp 0 1 volume ) - ] - else - Nothing +volumeChanged : Identifier -> Float -> Engine -> List E.Value +volumeChanged ( id, list ) volume (E e) = + [ E.object + [ ( "action", E.string "volume" ) + , ( "id", E.string <| e.parentUid ++ Gear.toUID id ) + , ( "beadIndexes", E.list E.int list ) + , ( "value", E.float <| clamp 0 1 volume ) + ] + ] -encodeWheel : Wheel -> Bool -> List ( String, E.Value ) -encodeWheel w hasView = +encodeWheel : Wheel -> Bool -> String -> List ( String, E.Value ) +encodeWheel w hasView parentUid = [ ( "mute", E.bool w.mute ) , ( "volume", E.float <| clamp 0 1 w.volume ) , ( "startPercent", E.float w.startPercent ) @@ -116,18 +110,20 @@ encodeWheel w hasView = ] ++ (case Wheel.getWheelContent w of Content.S s -> - [ ( "soundName", E.string <| Sound.toString s ) ] + [ ( "soundName", E.string <| Sound.toString s ) + , ( "loopPoints", E.list E.float <| Sound.getLoopPoints s ) + ] Content.M m -> - [ ( "mobile", encodeMobile m False ) ] + [ ( "mobile", encodeMobile m False parentUid ) ] Content.C c -> - [ ( "collar", encodeCollar c False ) ] + [ ( "collar", encodeCollar c hasView parentUid ) ] ) -encodeGear : Bool -> Coll Geer -> Id Geer -> E.Value -encodeGear hasView coll id = +encodeGear : Bool -> String -> Coll Geer -> Id Geer -> E.Value +encodeGear hasView parentUid coll id = let g = Coll.get id coll @@ -136,7 +132,7 @@ encodeGear hasView coll id = Harmo.getLength g.harmony coll uid = - Gear.toUID id + parentUid ++ Gear.toUID id in if length == 0 then Debug.log (uid ++ "’s length is 0") E.null @@ -146,30 +142,36 @@ encodeGear hasView coll id = ([ ( "id", E.string <| uid ) , ( "length", E.float length ) ] - ++ encodeWheel g.wheel hasView + ++ encodeWheel g.wheel hasView uid ) -encodeMobile : Mobeel -> Bool -> E.Value -encodeMobile { motor, gears } hasView = +encodeMobile : Mobeel -> Bool -> String -> E.Value +encodeMobile { motor, gears } hasView parentUid = E.object [ ( "length", E.float <| Harmo.getLengthId motor gears ) - , ( "gears", E.list (encodeGear hasView gears) <| Motor.getMotored motor gears ) + , ( "gears", E.list (encodeGear hasView parentUid gears) <| Motor.getMotored motor gears ) ] -encodeCollar : Colleer -> Bool -> E.Value -encodeCollar c hasView = +encodeCollar : Colleer -> Bool -> String -> E.Value +encodeCollar c hasView parentUid = E.object [ ( "length", E.float <| Collar.getCumulLengthAt c.matrice c ) , ( "loopStart", E.float c.loop ) - , ( "beads", E.list (encodeBead hasView) <| Collar.getBeads c ) + , ( "beads", E.list (encodeBead hasView parentUid) <| List.indexedMap (\i el -> ( i, el )) <| Collar.getBeads c ) ] -encodeBead : Bool -> Beed -> E.Value -encodeBead hasView b = +encodeBead : Bool -> String -> ( Int, Beed ) -> E.Value +encodeBead hasView parentUid ( i, b ) = + let + uid = + Content.beadUIDExtension parentUid i + in E.object - (( "length", E.float b.length ) - :: encodeWheel b.wheel hasView + ([ ( "length", E.float b.length ) + , ( "id", E.string uid ) + ] + ++ encodeWheel b.wheel hasView uid ) diff --git a/src/Interact.elm b/src/Interact.elm index 34763b0..f3913e2 100644 --- a/src/Interact.elm +++ b/src/Interact.elm @@ -131,7 +131,7 @@ type Action zone type alias DragInfo zone = - { init : ( Vec2, zone ) + { start : ( Vec2, zone ) , oldPos : Vec2 , newPos : Vec2 , startD : Vec2 @@ -180,7 +180,7 @@ update msg (S state) = , Just <| Event (Dragged - { init = dragInit + { start = dragInit , oldPos = click.pos , newPos = pos , startD = Vec.sub abs click.abs diff --git a/src/Sound.elm b/src/Sound.elm index b0796eb..fa9568f 100644 --- a/src/Sound.elm +++ b/src/Sound.elm @@ -8,7 +8,9 @@ import Json.Encode as E type Sound = S { path : String - , length : Float + , duration : Float + , startPercent : Float + , endPercent : Float } @@ -21,12 +23,12 @@ type Sound noSound = - S { path = "NO_SOUND", length = 0 } + S { path = "NO_SOUND", duration = 0, startPercent = 0, endPercent = 0 } length : Sound -> Float length (S s) = - s.length + s.duration * (s.endPercent - s.startPercent) toString : Sound -> String @@ -34,6 +36,47 @@ toString (S { path }) = path +fileName : Sound -> String +fileName (S { path }) = + Maybe.withDefault "" <| + List.head <| + String.split "." <| + Maybe.withDefault "" <| + List.head <| + List.reverse <| + String.split "/" path + + +getLoopPoints : Sound -> List Float +getLoopPoints (S { startPercent, endPercent, duration }) = + [ startPercent * duration, endPercent * duration ] + + +getLoopPercents : Sound -> ( Float, Float ) +getLoopPercents (S { startPercent, endPercent }) = + ( startPercent, endPercent ) + + +setLoop : ( Maybe Float, Maybe Float ) -> Sound -> Sound +setLoop mays (S s) = + case mays of + ( Just start, Nothing ) -> + S { s | startPercent = clamp 0 s.endPercent start } + + ( Nothing, Just end ) -> + S { s | endPercent = clamp s.startPercent 1 end } + + ( Just start, Just end ) -> + let + safeStart = + clamp 0 1 start + in + S { s | startPercent = safeStart, endPercent = clamp safeStart 1 end } + + _ -> + S s + + chgPath : Sound -> String -> Sound chgPath (S s) p = S { s | path = p } @@ -45,16 +88,24 @@ decoder = \p -> Field.require "length" D.float <| \l -> - D.succeed <| - S - { path = p - , length = l - } + Field.attempt "startPercent" D.float <| + \mayStart -> + Field.attempt "endPercent" D.float <| + \mayEnd -> + D.succeed <| + S + { path = p + , duration = l + , startPercent = Maybe.withDefault 0 mayStart + , endPercent = Maybe.withDefault 1 mayEnd + } encoder : Sound -> E.Value encoder (S s) = E.object <| [ ( "path", E.string s.path ) - , ( "length", E.float s.length ) + , ( "length", E.float s.duration ) + , ( "startPercent", E.float s.startPercent ) + , ( "endPercent", E.float s.endPercent ) ] diff --git a/src/Waveform.elm b/src/Waveform.elm index 6ce91d0..44ae64b 100644 --- a/src/Waveform.elm +++ b/src/Waveform.elm @@ -1,13 +1,13 @@ port module Waveform exposing (..) +import Editor.Interacting exposing (..) import Element exposing (..) import Element.Background as Bg import Element.Border as Border -import Element.Input as Input import Html exposing (canvas) import Html.Attributes as Attr +import Interact import Json.Decode as D -import Sound exposing (Sound) @@ -25,39 +25,58 @@ canvasId = "waveform" +border : Int +border = + 2 + + type alias Waveform = { size : Int , drawn : Drawing + , sel : Maybe ( Int, Int ) } type Drawing = None - | SoundDrawn Sound - | Pending Sound + | SoundDrawn String + | Pending String init : Waveform init = { size = 1000 , drawn = None + , sel = Nothing } +getSelPercents : Waveform -> Maybe ( Float, Float ) +getSelPercents { sel, size } = + let + toPercent px = + toFloat px / toFloat size + in + Maybe.map (Tuple.mapBoth toPercent toPercent) sel + + type Msg = GotSize Int - | ChgSound Sound + | ChgSound String | GotDrawn (Result D.Error String) + | Select ( Float, Float ) + | MoveSel Float + | CancelSel update : Msg -> Waveform -> ( Waveform, Cmd Msg ) update msg wave = case msg of GotSize size -> - ( { wave | size = size } + ( { wave | size = size - 2 * border } , case wave.drawn of SoundDrawn s -> - requestSoundDraw <| Sound.toString s + requestSoundDraw s _ -> Cmd.none @@ -68,18 +87,18 @@ update msg wave = ( wave, Cmd.none ) else - ( { wave | drawn = Pending s }, requestSoundDraw <| Sound.toString s ) + ( { wave | drawn = Pending s }, requestSoundDraw s ) GotDrawn res -> case res of Ok str -> case wave.drawn of Pending s -> - if Sound.toString s == str then + if s == str then ( { wave | drawn = SoundDrawn s }, Cmd.none ) else - ( wave, requestSoundDraw <| Sound.toString s ) + ( wave, requestSoundDraw s ) _ -> ( wave, Cmd.none ) @@ -87,40 +106,138 @@ update msg wave = Err err -> Debug.log ("Error while drawing " ++ D.errorToString err) ( wave, Cmd.none ) + Select ( centerPx, percentLength ) -> + let + halfSel = + round (percentLength * toFloat wave.size / 2) + + safeCenter = + clamp halfSel (wave.size - halfSel) <| round centerPx + in + ( { wave | sel = Just ( safeCenter - halfSel, safeCenter + halfSel ) }, Cmd.none ) + + MoveSel d -> + case wave.sel of + Just ( px1, px2 ) -> + let + move = + (+) <| clamp -px1 (wave.size - px2) <| round d + in + ( { wave | sel = Just ( move px1, move px2 ) }, Cmd.none ) + + Nothing -> + ( wave, Cmd.none ) + + CancelSel -> + ( { wave | sel = Nothing }, Cmd.none ) + sub : Sub Msg sub = soundDrawn (GotDrawn << D.decodeValue D.string) -view : Bool -> Waveform -> Float -> (Float -> msg) -> Element msg -view visible { size } percent chg = +view : + Bool + -> Waveform + -> { offset : Float, start : Float, end : Float } + -> Interact.State Interactable Zone + -> (Interact.Msg Interactable Zone -> msg) + -> Element msg +view visible wave cursors interState wrapInter = let - border = - 2 + toPx = + round << ((*) <| toFloat wave.size) in el - [ htmlAttribute <| Attr.hidden <| not visible - , Border.color <| rgb 0 0 0 - , Border.width border - , Bg.color <| rgb 1 1 1 - , alignBottom - , inFront <| - Input.slider [ htmlAttribute <| Attr.hidden <| not visible, height fill ] - { label = Input.labelHidden "Point de départ" - , onChange = chg - , min = 0 - , max = 1 - , value = percent - , thumb = Input.thumb [ width <| minimum 4 shrink, height fill, Bg.color <| rgb 0.2 0.2 0.8 ] - , step = Nothing - } - ] + (if visible then + (List.map (htmlAttribute << Attr.map wrapInter) <| Interact.dragSpaceEvents interState ZWave) + ++ [ Border.color <| rgb 0 0 0 + , Border.width border + , Bg.color <| rgb 1 1 1 + , alignBottom + ] + ++ List.map (mapAttribute wrapInter) + ([ selection ( toPx 0, toPx cursors.start ) Nothing <| rgba 0.5 0.5 0.5 0.5 + , selection ( toPx cursors.end, toPx 1 ) Nothing <| rgba 0.5 0.5 0.5 0.5 + , selection ( toPx cursors.start, toPx cursors.end ) (Just IWaveSel) <| rgba 0 0 0 0 + , cursor (toPx cursors.start) LoopStart + , cursor (toPx cursors.end) LoopEnd + , cursor (toPx cursors.offset) StartOffset + ] + ++ (case wave.sel of + Just points -> + [ selection points Nothing <| rgba 0.3 0.3 0.3 0.3 ] + + Nothing -> + [] + ) + ) + + else + [] + ) <| html <| canvas [ Attr.hidden <| not visible , Attr.id canvasId - , Attr.width (size - 2 * border) + , Attr.width wave.size ] [] + + +cursor : Int -> Cursor -> Attribute (Interact.Msg Interactable zone) +cursor pos cur = + inFront <| + el + ([ htmlAttribute <| Attr.style "cursor" "ew-resize" + , Border.width <| border + , height fill + , moveRight <| toFloat <| pos - border + , inFront <| + el + ([ htmlAttribute <| Attr.style "cursor" "grab" + , height <| px <| border * 8 + , width <| px <| border * 8 + , Border.rounded <| border * 4 + , Bg.color <| rgb 0 0 0 + , moveLeft <| toFloat <| border * 4 + ] + ++ (case cur of + LoopStart -> + [ alignTop, moveUp <| toFloat border ] + + LoopEnd -> + [ alignBottom, moveDown <| toFloat border ] + + StartOffset -> + [ centerY ] + ) + ) + none + ] + ++ (List.map htmlAttribute <| Interact.draggableEvents <| IWaveCursor cur) + ) + none + + +selection : ( Int, Int ) -> Maybe Interactable -> Color -> Attribute (Interact.Msg Interactable zone) +selection ( a, b ) mayInter color = + inFront <| + el + ([ Bg.color color + , width <| px (b - a + 1) + , height fill + , moveRight <| toFloat <| a + ] + ++ (Maybe.withDefault [] <| + Maybe.map + (List.map htmlAttribute + << (::) (Attr.style "cursor" "move") + << Interact.draggableEvents + ) + mayInter + ) + ) + none