trap cursor in screen ("ausgerudert")

2 files changed, 98 insertions, 31 deletions

diff --git a/TreeSearch.hs b/TreeSearch.hs
index 7b2e93e..40b3c17 100644
--- a/TreeSearch.hs
+++ b/TreeSearch.hs
@@ -2,6 +2,7 @@ module TreeSearch where
 
 import Data.Tree.Zipper
 
+
 findTree :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a)
 findTree p loc = if p (label loc)
     then Just loc
@@ -41,8 +42,33 @@ findPrev loc =
             Just x' -> trans_lastChild x'
 
 
+
+findNextN :: Int -> TreePos Full a -> TreePos Full a
+findNextN n loc
+    | n <= 0 = loc
+    | otherwise =
+        maybe loc (findNextN $ n - 1) (findNext loc)
+
+
+findPrevN :: Int -> TreePos Full a -> TreePos Full a
+findPrevN n loc
+    | n <= 0 = loc
+    | otherwise =
+        maybe loc (findPrevN $ n - 1) (findPrev loc)
+
+
+
 findParent :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a)
 findParent p loc =
     if p (label loc)
         then Just loc
         else parent loc >>= findParent p
+
+
+linearPos :: TreePos Full a -> Int
+linearPos =
+    rec 0
+  where
+    rec i loc = case findPrev loc of
+        Just loc' -> rec (i + 1) loc'
+        Nothing -> i
diff --git a/test4.hs b/test4.hs
index db2a701..b5336fe 100644
--- a/test4.hs
+++ b/test4.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE RecordWildCards #-}
 
 import Control.Applicative
-import Control.Concurrent
 import Control.Exception
 import Data.Maybe
 import Scanner (scan, runScanner, toChar)
@@ -33,6 +32,8 @@ data State = State
     , flashMessage :: String
     , screenWidth :: Int
     , screenHeight :: Int
+    , headBuffer :: [String]
+    , treeBuffer :: [String]
     }
 
 
@@ -64,8 +65,6 @@ initState = do
               hPutStr stdout "\ESC[?1049h"
               -- Hide Cursor
               hPutStr stdout "\ESC[?25l"
-              -- Move the cursor to the home position
-              hPutStr stdout "\ESC[H"
               hFlush stdout
         , discharge = do
               _ <- installHandler 28 Default Nothing
@@ -80,11 +79,14 @@ initState = do
         , flashMessage = "Welcome to much; quit with ^C"
         , screenWidth = 0
         , screenHeight = 0
+        , headBuffer = []
+        , treeBuffer = []
         }
 
 
 run :: State -> IO ()
-run q = do
+run q0 = do
+    let q = render q0
 
     redraw q
 
@@ -98,28 +100,42 @@ run q = do
             run q { flashMessage = show $ map toChar s }
 
 
-redraw :: State -> IO ()
-redraw _q@State{..} = do
+render :: State -> State
+render q@State{..} =
+    q { treeBuffer = newTreeBuf
+      , headBuffer = newHeadBuf
+      }
+  where
+    newTreeBuf = renderTreeView (Z.label cursor) (Z.toTree cursor)
+    newHeadBuf =
+        [ show screenWidth ++ "x" ++ show screenHeight
+          --show (linearPos cursor + 1) ++ "/" ++ show (length uncut)
+          ++ " " ++ show (linearPos cursor - yoffset)
+          ++ " " ++ show (topOverrun q)
+          ++ " " ++ show (botOverrun q)
+          ++ " " ++ flashMessage
+        , "--"
+        , "--"
+        , "--"
+        ]
 
-    --putStrLn $ describe (Z.label cursor)
-    --putStr "\ESC[?2J"
-    putStr "\ESC[H"
-    --mapM_ putStr $ take screenHeight $ repeat "\ESC[2K\n"
-    --putStr "\ESC[H"
 
-    -- consumes 1 screenHeight
-    putStr $ "\ESC[2K" ++ flashMessage ++ " " ++ show (screenWidth, screenHeight)
 
+redraw :: State -> IO ()
+redraw _q@State{..} = do
 
-    let buf = map (take screenWidth . drop xoffset) $
-              take (screenHeight - 1) $
-              drop yoffset $
-              renderTreeView (Z.label cursor) (Z.toTree cursor)
+    let image =
+            map (take screenWidth . drop xoffset) $
+            take screenHeight $
+            headBuffer ++ drop yoffset treeBuffer
+        screen =
+            image ++ take (screenHeight - length image) (repeat "~")
 
-    mapM_ (putStr . ("\n\ESC[2K"++)) $
-        buf
-        ++
-        take (screenHeight - 1 - length buf) (repeat "~")
+    case map (++"\ESC[K") screen of
+      (first : rest) ->
+          putStr $ "\ESC[H" ++ first ++ concatMap ("\n"++) rest
+      _ ->
+          return ()
 
 
 
@@ -134,12 +150,12 @@ keymap :: String -> Maybe (State -> IO State)
 
 keymap "r" = Just replyToAll
 keymap "e" = Just viewSource
-keymap "k" = Just moveCursorUp
-keymap "j" = Just moveCursorDown
+keymap "k" = Just $ moveCursorUp 1
+keymap "j" = Just $ moveCursorDown 1
 keymap "K" = Just $ moveTreeDown 1
 keymap "J" = Just $ moveTreeUp 1
-keymap "\ESC[A" = Just moveCursorUp
-keymap "\ESC[B" = Just moveCursorDown
+keymap "\ESC[A" = Just $ moveCursorUp 1
+keymap "\ESC[B" = Just $ moveCursorDown 1
 keymap "\ESC[a" = Just $ moveTreeDown 1
 keymap "\ESC[b" = Just $ moveTreeUp 1
 keymap "\ESC[5~" = Just $ \q -> moveTreeDown (screenHeight q `div` 2) q   -- PgUp
@@ -152,17 +168,42 @@ keymap ('\ESC':'[':'9':';':xs) = Just $ \q@State{..} -> do
 keymap _ = Nothing
 
 
-moveCursorDown q@State{..} =
-    return q { cursor = fromMaybe (Z.root cursor) $ findNext cursor }
 
-moveCursorUp q@State{..} =
-    return q { cursor = fromMaybe (Z.root cursor) $ findPrev cursor }
+topOverrun State{..} =
+    max 0 (- (linearPos cursor - yoffset))
+
+botOverrun State{..} =
+    max 0 (linearPos cursor - yoffset - (screenHeight - (length headBuffer) - 1))
+
+
+moveCursorDown n q@State{..} =
+    let cursor' = findNextN n cursor
+        q' = q { cursor = cursor' }
+    in case botOverrun q' of
+        0 -> return q'
+        i -> moveTreeUp i q'
+
+
+moveCursorUp n q@State{..} =
+    let cursor' = findPrevN n cursor
+        q' = q { cursor = cursor' }
+    in case topOverrun q' of
+        0 -> return q'
+        i -> moveTreeDown i q'
+
 
 moveTreeUp n q@State{..} =
-    return q { yoffset = max 0 (yoffset + n) }
+    let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset + n) }
+    in case topOverrun q' of
+        0 -> return q'
+        i -> moveCursorDown i q'
+
 
 moveTreeDown n q@State{..} =
-    return q { yoffset = max 0 (yoffset - n) }
+    let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset - n) }
+    in case botOverrun q' of
+        0 -> return q'
+        i -> moveCursorUp i q'
 
 
 toggleFold q@State{..} = case Z.label cursor of