ScrollF

module ScrollF(scrollShellF,
               scrollF,oldScrollF,
               vScrollF,oldVscrollF,
	       hScrollF,oldHscrollF,
	       grabScrollKeys) where
import Fudget
import EitherUtils
import CmdLineEnv(argFlag)
import Utils(remove)
import LayoutRequest
import Geometry
import Command
import FRequest
import Event
import Xtypes

import FreeGroupF
import Dlayout(groupF)
import DShellF(shellF)
import Spops
import NullF(nullF)
import Cont(waitForSP)
import SpEither(mapFilterSP)
import DragF(hPotF',vPotF',PotRequest(..))
import Placer(tableF,hBoxF,vBoxF)
import SerCompF(absF)
import Loops(loopThroughRightF)
import CompOps
--import Maptrace(ctrace)

scrollShellF name initlimits = shellF name . oldScrollF True initlimits

grabScrollKeys = argFlag "grabscrollkeys" False
 -- True is not good if there are two or more scrollFs in the same shell window.

-- Std versions with arbirarily chosen limits...
scrollF = oldScrollF grabScrollKeys (pP 50 30,pP 550 700)
vScrollF = oldVscrollF grabScrollKeys (pP 50 30,pP 550 700)
hScrollF = oldHscrollF grabScrollKeys (pP 50 10,pP 550 700)

scroll foc = (const,plainAdjLayout,tableF 2,vPotF' foc Nothing >+< hPotF' foc Nothing)
vscroll foc = (const,wAdjLayout,hBoxF,vPotF' foc Nothing >+< nullF)
hscroll foc = (const,hAdjLayout,vBoxF,nullF>+<hPotF' foc Nothing)

oldScrollF grabKeys  = gScrollF (scroll  (not grabKeys)) grabKeys
oldVscrollF grabKeys = gScrollF (vscroll (not grabKeys)) grabKeys
oldHscrollF grabKeys = gScrollF (hscroll (not grabKeys)) grabKeys

gScrollF (outCoupling,inCoupling,placer,scrollbarsF) grabKeys initlimits fud =
    loopThroughRightF (placer mainF) (absF (initSP ctrlSP))
  where
    mainF =
        post>^=<
	(groupF start visibleK (freeGroupF fud)>+<scrollbarsF)
	>=^<pre
      where
        post = swapRight.mapEither assocLeft id -- (KV+(T+a))+S -> ((KV+T)+S)+a
	pre = mapEither assocRight id.swapRight -- converse

        start = map XCmd $
	        transinit++
	        [ChangeWindowAttributes [CWBackPixmap parentRelative],
		 ConfigureWindow [CWBorderWidth 1]]

	transinit =
	    if grabKeys
	    then [TranslateEvent tobutton [KeyPressMask]]
	    else []

      --tobutton k@(KeyEvent t p1 p2 s Pressed _ ks _) | (s, ks) `elem` keys =
	tobutton e@(KeyEvent {state=s,type'=Pressed,keySym=ks})
	           | (s, ks) `elem` keys =
	    Just e
        -- Mouse Wheel support:
	tobutton e@(ButtonEvent {button=Button 4,type'=Pressed}) = Just e
	tobutton e@(ButtonEvent {button=Button 5,type'=Pressed}) = Just e
	tobutton _ = Nothing

        keys = map ((,) []) keys' ++ map ((,) [Shift]) keys'
	  where keys' = ["Prior","Next","Home","End"]

    -- visibleK reports the current visible size and grabbed keys
    visibleK = K{-kk-} $ mapFilterSP visible
      where
	visible (Low (LEvt (LayoutSize vissize))) = Just (High (Right vissize))
	visible (Low (XEvt (KeyEvent{state=mods,type'=Pressed,keySym=key}))) =
	    Just (High (Left (mods,key)))
	visible (Low (XEvt (ButtonEvent{button=Button 4,type'=Pressed,state=mods}))) =
	    Just (High (Left (mods,"Prior")))
	visible (Low (XEvt (ButtonEvent{button=Button 5,type'=Pressed,state=mods}))) =
	    Just (High (Left (mods,"Next")))
	visible (High vissize) =
	    Just (Low (layoutRequestCmd (plainLayout vissize False False)))
	visible _ = Nothing

    initSP cont =
        waitForSP initreq $ \ req ->
	let vissize = limit initlimits rtotsize
            rtotsize = minsize req
	    adj = inCoupling req
	in putSP (Left (Left vissize)) $
	   cont vissize rtotsize adj
      where initreq (Left (Right (LayoutRequest req))) = Just req
            initreq _ = Nothing

    -- ctrlSP :: SP ((KV+T)+S) ((V+T)+S)
    -- cltrSP implements the scrolling
    -- Input : KV = grabbed keys or visible size (from visibleK)
    --       : T = total size (from freeGroupF)
    --       : S = scroll bar positions
    -- Output: V = requested visible size (to visibleK)
    --         S = scroll bar adjustments on size changes
    --         T = position adjustments on scroll bar changes,
    --             notification of current visible size
    ctrlSP visible total adj =
        concatMapAccumlSP ctrlT (visible, total, pP 0 0,adj) -- limits??
      where
        ctrlT s@(visible, total, pos, adj) msg =
	    case msg of
	      Left (Left (Left key)) -> (s,potKeyInput key)
	      Left (Left (Right visible')) -> adjustVisible visible' adj
	      Left (Right req) ->
	        case req of
		  LayoutRequest req -> adjustVisible visible adj'
		     where adj' = inCoupling req
		  LayoutMakeVisible rect align ->
		    (s, mkvisible rect align)
		  --LayoutScrollStep step -> ...
		  _ -> (s, [])
	      Right (Left (y,_,_)) -> vmove pos (-y)
	      Right (Right (x,_,_)) -> hmove pos (-x)
	  where
	    potKeyInput key@(mods,k) =
	      if Shift `elem` mods
	      then [Right (Right (PotInput (remove Shift mods,k)))]
	      else [Right (Left  (PotInput key))]
	    adjustVisible visible' adj' =
		((visible', total', pos, adj'),
		 Left (Right (Left total')):
		 adjustPots visible' total')
	      where total' = adj' visible'
	    adjustPots (Point visw vish) size@(Point totw toth) =
		    [Right (Right (ResizePot visw totw)),
		     Right (Left (ResizePot vish toth))]
	    mkvisible r@(Rect (Point x y) (Point w h)) (halign,valign) =
	      --ctrace "mkvisible" r $
		    [Right (Right (PotMkVisible x w halign)),
		     Right (Left (PotMkVisible y h valign))]
	    vmove pos@(Point x _) y =
	        --ctrace "vmove" (pos,pos') $
	        ((visible,total,pos',adj),[Left (Right (Right pos'))])
	      where pos' = Point x y
	    hmove pos@(Point _ y) x =
	        --ctrace "hmove" (pos,pos')
	        ((visible,total,pos',adj),[Left (Right (Right pos'))])
	      where pos' = Point x y


limit (min', max') size = pmax min' (pmin max' size)


type SizeCoupling = Size    -> Size      -> Size
--                  my size    other size   my new size

stdCoupling = pmax
vCoupling (Point tw th) (Point vw vh) = Point vw (max th vh)
hCoupling (Point tw th) (Point vw vh) = Point (max tw vw) vh

plainAdjLayout (Layout {minsize=total'}) = stdCoupling total'
wAdjLayout (Layout {wAdj=wa}) = s (flip vCoupling) (wa . xcoord)
hAdjLayout (Layout {hAdj=ha}) = s (flip hCoupling) (ha . ycoord)

s f g x = f x (g x)

-- assocLeft :: a+(b+c) -> (a+b)+c
-- assocRight :: (a+b)+c -> a+(b+c)
assocLeft = either (Left. Left) (either (Left. Right) Right)
assocRight = either (either Left (Right. Left)) (Right. Right)

--swapRight :: (a+b)+c -> (a+c)+b
swapRight = either (either (Left. Left) Right) (Left. Right)