got edited cells to hightlight with red border

they do it even when there is no diagram drawn yet though, which is not
really desirable behaviour (I think?).  Anyhow, that will be revisited
over the break.

Author: octalsrc

src/Demo/JS.hs

@@ -4,9 +4,13 @@ module Demo.JS ( readInputState
                , mkRandomInput
                , sDrawButton
                , printHighError
+               , sCellsDiv
+               , sNumCells
                , printLowError
                , cullErrors
+               , mark
                , sRandomButton 
+               , sLowerControls
                , drawList
                , placeValues
                , displayOutput
@@ -34,6 +38,7 @@ canvasXPadding = 1 :: Double
 canvasYPadding = 1 :: Double
 scaleMax = 100 :: Double
 
+sLowerControls = select "#c"
 sNumCells = select "#numcells"
 sStartHead = select "#starthead"
 sCellGen = select "#generatenew"
@@ -52,6 +57,37 @@ sCellNum i = select (pack (template (cellMkName i)))
                      ++ n 
                      ++ "\" type=\"text\" name=\"a\" /></div>"
 
+mark :: (Bool, [Int]) -> IO ()
+mark (b,is) = markHead b >> unMarkCells >> markCells is
+
+markHead :: Bool -> IO ()
+markHead b = 
+  if b
+     then sHeadInput 
+          >>= setAttr "style" "border-color: red;" 
+          >> return ()
+     else sHeadInput
+          >>= setAttr "style" "border-color: black;"
+          >> return ()
+
+unMarkCells = do start <- pullVal sStartDiv
+                 size <- pullVal sSizeDiv
+                 let f a = select (pack ("#hey" ++ (show a)))
+                           >>= setAttr "style" "border-color: black;"
+                           >> return ()
+                     r i s = if i < s
+                                then f i >> r (i + 1) s
+                                else return ()
+                 r start (start + size)
+
+markCells is = do let r :: [Int] -> IO ()
+                      r (i:is) = f i >> r is
+                      r [] = return ()
+                      f a = select (pack ("#hey" ++ (show a)))
+                            >>= setAttr "style" "border-color: red;"
+                            >> return ()
+                  r is
+
 getGenInfo :: IO (Either String (Int, Int))
 getGenInfo = 
   do start <- fmap unpack (sStartHead >>= getVal)

src/Demo/Links.hs

@@ -3,12 +3,13 @@ module Demo.Links ( parseInput
                   , findScale 
                   , scaleMap
                   , nmap
+                  , mismatches
                   , mkLayout ) where
 
 import Text.Read (readMaybe)
 import System.Random
 import Demo.Types
-import qualified Data.Map as M (empty, lookup)
+import qualified Data.Map as M (Map, empty, lookup)
 import qualified Data.List as L (delete, length)
 
 -- Config!
@@ -20,6 +21,21 @@ randomValueRange = ('A','Z')
    for later.
    -}
 
+mismatches :: InputState -> InputState -> (Bool,[Int])
+mismatches (InSt i1 s1 h1 m1) (InSt i2 s2 h2 m2) = 
+  let headChanged = h1 /= h2
+      f = (matchIndex m1 m2)
+  in (headChanged, (foldr 
+                     f
+                     []
+                     [i1 .. (i1 + s1 - 1)] ))
+
+matchIndex :: M.Map Int Cell -> M.Map Int Cell -> Int -> [Int] -> [Int]
+matchIndex c b i is = let f m = (fmap snd (M.lookup i m)) 
+                      in if (f c) == (f b)
+                            then is
+                            else i:is
+
 {- There are two implemented functions for Step:
    1. arrow: "we're looking for an arrow next"
    2. box: "we're looking for a box next"

src/LinkedListDemo.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# LANGUAGE CPP, OverloadedStrings, ForeignFunctionInterface #-}
 
 import Reactive.Banana
 import Reactive.Banana.Frameworks
@@ -14,11 +14,19 @@ defaultHeadIndex = 23
 defaultNumCells = 14
 
 main = do initializePage (defaultHeadIndex, defaultNumCells)
-          (draw, rando, gener) <- mkSources
+          (draw, rando, gener, clicks, keys) <- mkSources
           wireButton draw sDrawButton (cullErrors >> readInputState)
-          wireButton rando sRandomButton (cullErrors >> mkRandomInput)
-          wireButton gener sCellGen (cullErrors >> generateCells)
-          n <- compile (mkNetwork (draw, rando, gener))
+          wireButton rando sRandomButton (cullErrors 
+                                          >> mkCanvas
+                                          >>mkRandomInput
+                                          >> readInputState)
+          wireButton 
+            gener 
+            sCellGen 
+            (cullErrors >> generateCells >> readInputState)
+          wireClicks clicks
+          wireKeys keys readInputState
+          n <- compile (mkNetwork (draw, rando, gener, clicks, keys))
           actuate n
 
 generateCells :: IO ()
@@ -39,7 +47,10 @@ initializePage (start,size) =
   >> writeInputState (emptyInput start size) 
   >> mkCanvas
 
-
+wireClicks _ = return () -- maybe implement this later?
+wireKeys (addHandler, fire) f = do let handler _ = f >>= fire
+                                   box <- sLowerControls
+                                   keyup handler def box
 
 wireButton (addHandler, fire) button f = do 
   let handler _ = f >>= fire
@@ -49,21 +60,37 @@ wireButton (addHandler, fire) button f = do
 mkSources = do a <- newAddHandler
                b <- newAddHandler
                c <- newAddHandler
-               return (a,b,c)
+               d <- newAddHandler
+               e <- newAddHandler
+               return (a,b,c,d,e)
 
 addHandler = fst
 fire = snd
 
-mkNetwork (drawSource, randomSource, genSource) = do 
+mkNetwork (drawSource, randomSource, genSource, clickSource, keySource) = do 
   eDraws <- fromAddHandler (addHandler drawSource)
   eRandoms <- fromAddHandler (addHandler randomSource)
-  let eInputs = eDraws `union` eRandoms
-      --bInputState :: Behavior t InputState
+  eGens <- fromAddHandler (addHandler genSource)
+  eKeys <- fromAddHandler (addHandler keySource)
+  let eResets = eRandoms `union` eGens
+      eInputs = eRandoms `union` eGens `union` eKeys
+      --bInputState :: Behavior t InputState 
       bInputState = stepper (emptyInput 5 20) eInputs
-      
+      eDrawnInputState = bInputState <@ eDraws
+      bLastInputState = stepper (emptyInput 5 20)
+                                (eDrawnInputState `union` eResets)
+      bDirty = mismatches <$> bInputState <*> bLastInputState
+  cIn <- changes bInputState
+  cLIn <- changes bLastInputState
+  cDirty <- changes bDirty
+
+
   --reactimate' $ fmap (\is -> process is) eISChanged
   --reactimate' <$> (fmap (fmap process) eISChanged)
   reactimate (fmap (\a -> mkCanvas >> process a) eDraws)
+  reactimate' $ fmap (\d -> mark d >> print (show d) >> return ()) <$> cDirty
+  reactimate' $ fmap (\d -> print ("InputState: " ++ show d)) <$> cIn
+  reactimate' $ fmap (\d -> print ("LastState: " ++ show d)) <$> cLIn
   --reactimate (fmap (\_ -> fmap process bInputState) eDraws)
 
 process :: InputState -> IO ()