MODULE StdScrollbars;
(**
	project	= "BlackBox 2.0, new module"
	organization	= "Oberon microsystems, BBWFC, OberonCore, BBCP Team"
	contributors	= "Contributors, Anton Dmitriev, Ketmar Dark, Ivan Denisov"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "The 2-Clause BSD License"
	changes	= "
	- 20230512, k8, changed scrollbars look
	- 20240521, dia, prevent fall if scrollbar size is small
	"
	issues	= "
	-
	"

**)

	IMPORT
		Views, Ports, Models, Controllers, Services, Properties;

	CONST
		left = 16; middle = 17; right = 18; (* HostPorts.left, .middle, .right *)
		vertical* = TRUE;	(* scrollbar orientation *)
		minThumbSize = 9;

	TYPE
		UCs = INTEGER;
		Pixels = INTEGER;

		Scrollbar* = POINTER TO ABSTRACT RECORD (Views.View)
			wholeSize*, partSize*, partPos*: INTEGER;
			isVertical*: BOOLEAN;
			lastDot-: INTEGER;
			(* the following is set by Recalc *)
			w, h: Pixels;	(* last known width and height *)
			size: Pixels;	(* last known scrollbar size *)
			thPos, thSize: Pixels	(* last known thumbnail position and size *)
		END;
		StdScrollbar = POINTER TO RECORD (Scrollbar) END;

		ScrollbarDirectory* = POINTER TO ABSTRACT RECORD END;
		StdScrollbarDirectory = POINTER TO RECORD (ScrollbarDirectory) END;

		(** a proposal indicating to the context that the scrollbar has been
			scrolled by the user. It is up to the receiver of the proposal to request
			(thru Views.Update) or force (thru Views.RestoreRoot) the
			restoration of the scrollbar. *)
		Proposal* = RECORD (Models.Proposal)
			sb*: Scrollbar;
			frame*: Views.Frame;	(** the sender may specify .sb's frame to allow optimizations in the receiver.
															ASSERT((.frame = NIL) OR (.frame.view = .sb)) *)
			op*: INTEGER	(** same constants as for Controllers.ScrollMsg.op *)
		END;

		Param* = RECORD
			thumbColor*: Ports.Color;
			thumbMin*: INTEGER;
			shaftColor*: Ports.Color;
			shaftShade*: INTEGER;
			disabledColor*: Ports.Color;
			leftGoto*: BOOLEAN;
			smallerThumb*: BOOLEAN;
			(* calculated colors *)
			clrShaft: Ports.Color;
			clrThumb: Ports.Color;
		END;

		FindFrameMsg = RECORD (Views.Message)
			frame: Views.Frame
		END;


	VAR
		sbDir*: ScrollbarDirectory;
		stdSbDir-: StdScrollbarDirectory;
		param: Param;


	PROCEDURE (VAR p: Param) InitDefaults, NEW;
	BEGIN
		p.thumbColor := Ports.grey50;
		p.thumbMin := 30;
		p.shaftColor := Ports.grey25;
		p.shaftShade := 0;
		p.disabledColor := Ports.white;
		p.leftGoto := TRUE;
		p.smallerThumb := TRUE;
	END InitDefaults;
	

	PROCEDURE (VAR p: Param) Init*, NEW;
	BEGIN
		IF (p.shaftShade > 0) & (p.shaftShade < 100) THEN
			p.clrShaft := Ports.blue
		ELSE
			p.clrShaft := p.shaftColor
		END;
		p.clrThumb := p.thumbColor;
	END Init;


	(** Scrollbar **)

	PROCEDURE GetSBSize (sb: Scrollbar): INTEGER;
	BEGIN
		IF param.smallerThumb THEN
			RETURN MAX(0, sb.size - 2)
		ELSE
			RETURN MAX(0, sb.size)
		END;
	END GetSBSize;

	PROCEDURE GetThumbOfs (sb: Scrollbar): INTEGER;
	BEGIN
		IF param.smallerThumb THEN RETURN 1 ELSE RETURN 0 END;
	END GetThumbOfs;

	(* thum size is proportional to the visible area size *)

	PROCEDURE CalcThumbSize (sb: Scrollbar): Pixels;
	VAR
		res: Pixels;
		sbsize: INTEGER;
	BEGIN
		sbsize := GetSBSize(sb);
		IF (sbsize <= 0) OR (sb.wholeSize <= 0) OR (sb.partSize > 0) & (sb.wholeSize <= sb.partSize) THEN
			res := sbsize
		ELSE
			res := MAX(minThumbSize, param.thumbMin);
			(* StdDocument often doesn't set part size *)
			IF sb.partSize > 0 THEN
				res := MAX(res, MIN(sbsize, SHORT(LONG(sbsize) * sb.partSize DIV sb.wholeSize)))
			END
		END;
		RETURN res
	END CalcThumbSize;

	(* sb.thSize should be already set *)
	PROCEDURE GetPartSize (sb: Scrollbar): INTEGER;
	VAR res: INTEGER;
	BEGIN
		res := sb.partSize;
		IF res <= 0 THEN ASSERT(sb.thSize >= minThumbSize, 100);
			IF sb.thSize >= GetSBSize(sb) THEN res := 0
			ELSE res := SHORT(LONG(sb.wholeSize) DIV (GetSBSize(sb) - sb.thSize))
			END
		END;
		RETURN MAX(0, res)
	END GetPartSize;

	PROCEDURE Recalc (sb: Scrollbar; dot: UCs);
	VAR pos, sz, sbsize: INTEGER;
	BEGIN
		sb.lastDot := dot;
		sb.context.GetSize(sb.w, sb.h);
		sb.w := sb.w DIV dot; sb.h := sb.h DIV dot;
		sb.size := 0; sb.thPos := 0; sb.thSize := 0;
		IF (sb.wholeSize > 0) & (sb.w > 0) & (sb.h > 0) THEN
			IF sb.isVertical THEN sb.size := sb.h ELSE sb.size := sb.w END;
			IF sb.size < minThumbSize + 3 THEN sb.size := 0
			ELSE
				sb.thSize := CalcThumbSize(sb);
				sbsize := GetSBSize(sb);
				IF (sbsize <= 0) OR (sb.wholeSize <= 0) OR (sb.wholeSize <= sb.partSize) THEN sb.thPos := 0
				ELSIF sb.thSize >= sbsize THEN sb.thPos := 0
				ELSE ASSERT(sb.thSize <= sbsize, 100);
					sz := sb.wholeSize - GetPartSize(sb);
					IF sz <= 0 THEN sz := 1 END;
					pos := MAX(0, MIN(sb.partPos, sz));
					sb.thPos := SHORT(LONG(sbsize - sb.thSize) * pos DIV sz)
				END
			END
		END
	END Recalc;

	(* tp is thumb position (top/left); result is the position in the sb range.
		should be called after Recalc. *)
	PROCEDURE Thumb2Pos (sb: Scrollbar; tp: Pixels): INTEGER;
	VAR res, sbsize: INTEGER;
	BEGIN
		sbsize := GetSBSize(sb);
		IF (tp <= 0) OR (sb.wholeSize <= 0) OR (sb.thSize = 0) THEN res := 0
		ELSIF tp >= sbsize - sb.thSize THEN res := sb.wholeSize - GetPartSize(sb)
		ELSE res := SHORT(LONG(sb.wholeSize - GetPartSize(sb)) * tp DIV (sbsize - sb.thSize))			END;
		RETURN res
	END Thumb2Pos;

	PROCEDURE (sb: StdScrollbar) Restore* (f: Views.Frame; l, t, r, b: INTEGER);
	VAR w, h, dot: UCs;
	BEGIN
		dot := f.dot;
		Recalc(sb, dot);
		IF GetSBSize(sb) = 0 THEN
			f.DrawRect(l, t, r, b, Ports.fill, param.disabledColor)
		ELSE
			f.DrawRect(l, t, r, b, Ports.fill, param.clrShaft);
			sb.context.GetSize(w, h);
			IF sb.isVertical THEN
				IF param.smallerThumb THEN l := dot; t := dot; r := w - dot
				ELSE l := 0; t := 0; r := w
				END;
				INC(t, sb.thPos * dot); b := t + sb.thSize * dot
			ELSE
				IF param.smallerThumb THEN l := dot; t := dot; b := h - dot
				ELSE l := 0; t := 0; b := h
				END;
				INC(l, sb.thPos * dot); r := l + sb.thSize * dot
			END;
			f.DrawRect(l, t, r, b, Ports.fill, param.clrThumb);
		END
	END Restore;

	PROCEDURE UpdateRoot (c: Views.Frame);
	VAR
		root: Views.RootFrame;
		l, t, r, b: INTEGER;
	BEGIN
		root := Views.UltimateRootOf(Views.RootOf(c));
		IF root # NIL THEN
			l := root.l + root.gx; t := root.t + root.gy; r := root.r + root.gx; b := root.b + root.gy;
			Views.RestoreRoot(root, l, t, r, b)
		END
	END UpdateRoot;

	PROCEDURE TrackThumb (sb: StdScrollbar; f: Views.Frame; msg: Controllers.TrackMsg);
	VAR
		p: Proposal;
		delta, q, x, y, ox, oy, partPos: INTEGER;
		ticks: LONGINT;
		mod: SET;
		isDown: BOOLEAN;
		ffm: FindFrameMsg;
	BEGIN
		IF GetSBSize(sb) > 0 THEN
			x := msg.x; y := msg.y; ox := x; oy := y;
			IF sb.isVertical THEN
				delta := y DIV f.dot - sb.thPos
			ELSE
				delta := x DIV f.dot - sb.thPos
			END;
			INC(delta, GetThumbOfs(sb));
			ticks := Services.Ticks();
			REPEAT
				IF f.rider # NIL THEN
					f.Input(x, y, mod, isDown)
				END;
				IF (sb.isVertical & (y # oy)) OR (~ sb.isVertical & (x # ox)) THEN
					IF sb.isVertical THEN q := y DIV f.dot ELSE q := x DIV f.dot END;
					partPos := Thumb2Pos(sb, q - delta);
					IF (partPos # sb.partPos) & (isDown OR (Services.Ticks() - ticks > 10)) THEN
						sb.partPos := partPos;
						p.sb := sb; p.op := Controllers.gotoPos; p.frame := f;
						sb.context.Consider(p);
						(* Consider may cause Views.Update with Views.rebuildFrames;
							if so, obtain the new frame *)
						IF f.rider = NIL THEN Views.Broadcast(sb, ffm); f := ffm.frame END;												(* k8: we need to do it this way,
							otherwise scrollbar and scroll visual positions could be wrong *)
						UpdateRoot(f);
						(* same check *)
						IF f.rider = NIL THEN Views.Broadcast(sb, ffm); f := ffm.frame END;
						ticks := Services.Ticks()
					END;
					ox := x; oy := y
				END
			UNTIL (f.rider = NIL) OR ~isDown
		ELSE
			REPEAT
				IF f.rider # NIL THEN f.Input(x, y, mod, isDown) END
			UNTIL (f.rider = NIL) OR ~isDown
		END
	END TrackThumb;

	(** w, h - dimensions of sb; ltrb - thumb bounding box *)
	PROCEDURE TrackShaft (sb: StdScrollbar; f: Views.Frame; msg: Controllers.TrackMsg);
	CONST
		interval = 500;
		none = -1;
		up = Controllers.decPage;
		down = Controllers.incPage;
	VAR
		p: Proposal;
		mod: SET;
		isDown: BOOLEAN;
		x, y, tp: INTEGER;
		dir: INTEGER;
		ticks, oticks: LONGINT;
	BEGIN
		p.sb := sb; x := msg.x; y := msg.y; oticks := 0;
		REPEAT
			ticks := Services.Ticks();
			IF (ticks - oticks > interval) & (f.l <= x) & (x < f.r) & (f.t <= y) & (y < f.b) THEN
				Recalc(sb, f.dot);
				IF GetSBSize(sb) > 0 THEN
					IF sb.isVertical THEN tp := y DIV f.dot ELSE tp := x DIV f.dot END;
					IF tp < sb.thPos + GetThumbOfs(sb) THEN dir := up
					ELSIF tp > sb.thPos + GetThumbOfs(sb) + sb.thSize THEN dir := down
					ELSE dir := none
					END;
					IF dir # none THEN p.op := dir; p.frame := f; sb.context.Consider(p) END
				END;
				oticks := ticks
			END;
			IF f.rider # NIL THEN f.Input(x, y, mod, isDown) END;
		UNTIL (f.rider = NIL) OR ~isDown
	END TrackShaft;

	PROCEDURE Goto (sb: StdScrollbar; f: Views.Frame; msg: Controllers.TrackMsg);
	VAR
		p: Proposal;
		q: INTEGER;
		partPos: INTEGER;
	BEGIN
		IF GetSBSize(sb) > 0 THEN
			IF sb.isVertical THEN q := msg.y DIV f.dot ELSE q := msg.x DIV f.dot END;
			DEC(q, sb.thSize DIV 2);
			partPos := Thumb2Pos(sb, q);
			IF partPos # sb.partPos THEN
				sb.partPos := partPos; p.sb := sb; p.op := Controllers.gotoPos; p.frame := f;
				sb.context.Consider(p)
			END
		END
	END Goto;

	PROCEDURE (sb: StdScrollbar) HandleCtrlMsg* (f: Views.Frame; VAR msg: Views.CtrlMessage; VAR focus: Views.View);
	VAR
		sbpos: Pixels;
	BEGIN
		WITH msg: Controllers.TrackMsg DO
			Recalc(sb, f.dot);
			IF sb.isVertical THEN sbpos := msg.y DIV f.dot ELSE sbpos := msg.x DIV f.dot END;
			INC(sbpos, GetThumbOfs(sb));
			IF middle IN msg.modifiers THEN
				Goto(sb, f, msg)
			ELSIF (sbpos >= sb.thPos) & (sbpos < sb.thPos + sb.thSize) THEN
				TrackThumb(sb, f, msg)
			ELSIF param.leftGoto & (left IN msg.modifiers) THEN
				Goto(sb, f, msg)
			ELSIF msg.modifiers * {left, right} # {} THEN
				TrackShaft(sb, f, msg)
			END
		ELSE END
	END HandleCtrlMsg;

	PROCEDURE (sb: StdScrollbar) HandlePropMsg- (VAR msg: Properties.Message);
	BEGIN WITH msg: Properties.FocusPref DO msg.hotFocus := TRUE ELSE END
	END HandlePropMsg;

	PROCEDURE (sb: StdScrollbar) HandleViewMsg- (f: Views.Frame; VAR msg: Views.Message);
	BEGIN WITH msg: FindFrameMsg DO msg.frame := f ELSE END
	END HandleViewMsg;

	PROCEDURE (sb: StdScrollbar) GetBackground* (VAR col: Ports.Color);
	BEGIN col := Views.transparent
	END GetBackground;


	(** Directory **)

	PROCEDURE (d: ScrollbarDirectory) New* (): Scrollbar, NEW, ABSTRACT;


	(** StdDirectory **)

	PROCEDURE (d: StdScrollbarDirectory) New (): Scrollbar;
	VAR sb: StdScrollbar;
	BEGIN
		NEW(sb);
		sb.isVertical := TRUE;
		sb.wholeSize := 0;
		RETURN sb
	END New;

BEGIN
	NEW(stdSbDir);
	sbDir := stdSbDir;
	param.InitDefaults;
	param.Init
END StdScrollbars.
