initial framework added

[fp1415-soccerfun.git] / src / StdLibExt / RangeSlider.icl

diff --git a/src/StdLibExt/RangeSlider.icl b/src/StdLibExt/RangeSlider.icl
new file mode 100644 (file)
index 0000000..7ae5ffa
--- /dev/null
+++ b/src/StdLibExt/RangeSlider.icl
@@ -0,0 +1,119 @@
+implementation module RangeSlider\r
+\r
+import StdEnv, StdIO\r
+\r
+::     RangeSliderId a\r
+       =       { sliderId      :: Id\r
+               , recId     :: R2Id (RangeSliderMsgIn a) (RangeSliderMsgOut a)\r
+               }\r
+::     RangeSliderMsgIn a\r
+       =       RSIn_GetIndex\r
+       |       RSIn_GetValue\r
+       |       RSIn_SetIndex RangeIndex\r
+       |       RSIn_SetValue a\r
+::     RangeSliderMsgOut a\r
+       =       RSOut_GetIndex RangeIndex\r
+       |       RSOut_GetValue a\r
+       |       RSOut_SetIndex\r
+       |       RSOut_SetValue\r
+::     RangeSliderSt a\r
+       :== Range a\r
+\r
+openRangeSliderId :: !*env -> (!RangeSliderId a,!*env) | Ids env\r
+openRangeSliderId env\r
+       # (sliderId,env)        = openId   env\r
+       # (recId,   env)        = openR2Id env\r
+       = ({sliderId=sliderId,recId=recId},env)\r
+\r
+instance Controls (RangeSlider a) where\r
+       controlToHandles (RangeSlider {sliderId,recId} dir width range=:{values,index} f atts) pSt\r
+               = controlToHandles impl pSt\r
+       where\r
+               f`              = liftF2 f\r
+               impl    = { addLS  = range\r
+                                 , addDef = SliderControl dir width state (action f`) [ControlId sliderId:map toLS atts]\r
+                                                               :+:\r
+                                                    Receiver2 recId (recF f`) []\r
+                                 }\r
+               state   = { sliderMin   = 0\r
+                                 , sliderMax   = length values - 1\r
+                                 , sliderThumb = index\r
+                                 }\r
+               \r
+               action f move ((range=:{values,index},ls),pSt)\r
+                               = f (values!!i) (({range & index=i},ls),appPIO (setSliderThumb sliderId i) pSt)\r
+               where\r
+                       i       = case move of\r
+                                       SliderIncSmall                  = min (index+1)                          (length values-1)\r
+                                       SliderDecSmall                  = max (index-1)                          0\r
+                                       SliderIncLarge                  = min (index+(max 1 (length values)/10)) (length values-1)\r
+                                       SliderDecLarge                  = max (index-(max 1 (length values)/10)) 0\r
+                                       SliderThumb new                 = new\r
+               \r
+               recF f RSIn_GetIndex ((range=:{index},ls),pSt)\r
+                       = (RSOut_GetIndex index,((range,ls),pSt))\r
+               recF f RSIn_GetValue ((range=:{values,index},ls),pSt)\r
+                       = (RSOut_GetValue (values!!index),((range,ls),pSt))\r
+               recF f (RSIn_SetIndex i) ((range=:{values},ls),pSt)\r
+                       = (RSOut_SetIndex,f (values!!i`) (({range & index=i`},ls),pSt))\r
+               where\r
+                       i`                                                              = min (max i 0) (length values-1)\r
+               recF f (RSIn_SetValue v) ((range=:{values,index},ls),pSt)\r
+                       = (RSOut_SetValue,f v (({range & values=updateAt index v values},ls),pSt))\r
+               \r
+               toLS (ControlActivate     f)            = ControlActivate   (liftF f)\r
+               toLS (ControlDeactivate   f)            = ControlDeactivate (liftF f)\r
+               toLS (ControlFunction     f)            = ControlFunction   (liftF f)\r
+               toLS  ControlHide                                       = ControlHide\r
+               toLS (ControlId           id)           = ControlId         id\r
+               toLS (ControlKeyboard     kF s f)       = ControlKeyboard kF s (liftF2 f)\r
+               toLS (ControlMinimumSize  s)            = ControlMinimumSize s\r
+               toLS (ControlModsFunction f)            = ControlModsFunction  (liftF2 f)\r
+               toLS (ControlMouse        mF s f)       = ControlMouse    mF s (liftF2 f)\r
+               toLS (ControlPen          p)            = ControlPen         p\r
+               toLS (ControlPos          p)            = ControlPos         p\r
+               toLS (ControlResize       f)            = ControlResize      f\r
+               toLS (ControlSelectState  s)            = ControlSelectState s\r
+               toLS (ControlTip          t)            = ControlTip         t\r
+               toLS (ControlWidth        w)            = ControlWidth       w\r
+               toLS (ControlHMargin      l r)          = ControlHMargin     l r\r
+               toLS (ControlHScroll      f)            = ControlHScroll     f\r
+               toLS (ControlItemSpace    x y)          = ControlItemSpace   x y\r
+               toLS (ControlLook         b f)          = ControlLook        b f\r
+               toLS (ControlOrigin       o)            = ControlOrigin      o\r
+               toLS (ControlOuterSize    s)            = ControlOuterSize   s\r
+               toLS (ControlViewDomain   d)            = ControlViewDomain  d\r
+               toLS (ControlViewSize     s)            = ControlViewSize    s\r
+               toLS (ControlVMargin      t b)          = ControlVMargin     t b\r
+               toLS (ControlVScroll      f)            = ControlVScroll     f\r
+               \r
+               liftF f ((add,ls),pSt)\r
+                       # (ls,pSt)      = f (ls,pSt)\r
+                       = ((add,ls),pSt)\r
+               \r
+               liftF2 f a ((add,ls),pSt)\r
+                       # (ls,pSt)      = f a (ls,pSt)\r
+                       = ((add,ls),pSt)\r
+       \r
+       getControlType _\r
+               = "RangeSlider"\r
+\r
+getRangeSliderIndex :: !(RangeSliderId a) !(PSt .ps) -> (!Maybe RangeIndex,!PSt .ps)\r
+getRangeSliderIndex {recId} pSt\r
+       = case syncSend2 recId RSIn_GetIndex pSt of\r
+               ((SendOk,Just (RSOut_GetIndex i)),pSt)  = (Just i, pSt)\r
+               (_,pSt)                                                                 = (Nothing,pSt)\r
+\r
+getRangeSliderValue :: !(RangeSliderId a) !(PSt .ps) -> (!Maybe a,!PSt .ps)\r
+getRangeSliderValue {recId} pSt\r
+       = case syncSend2 recId RSIn_GetValue pSt of\r
+               ((SendOk,Just (RSOut_GetValue v)),pSt)  = (Just v, pSt)\r
+               (_,pSt)                                                                 = (Nothing,pSt)\r
+\r
+setRangeSliderIndex :: !(RangeSliderId a) !Index !(PSt .ps) -> PSt .ps\r
+setRangeSliderIndex {recId} i pSt\r
+       = snd (syncSend2 recId (RSIn_SetIndex i) pSt)\r
+\r
+setRangeSliderValue :: !(RangeSliderId a) !a !(PSt .ps) -> PSt .ps\r
+setRangeSliderValue {recId} v pSt\r
+       = snd (syncSend2 recId (RSIn_SetValue v) pSt)\r