Obx/Mod/BlackBox.odc

MODULE ObxBlackBox;
(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	changes	= "
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)

	IMPORT Ports, Stores, Models, Views, Controllers, Properties, Fonts, Dialog, Services, Strings;

	CONST 
		minVersion = 0; maxVersion = 0;
		minded = -3; marked = -4; markedAndMinded = -7;	(* inside marks *)
		absorbed = -1; reflected = -2;	(* outside marks *)

	TYPE
		Model = POINTER TO RECORD (Models.Model)
			board : POINTER TO ARRAY OF ARRAY OF BYTE;
			m, (* size of board *)
			p, (* number of atoms *)
			n, (* number of actual guess *)
			score: INTEGER; 
			showsol: BOOLEAN
		END;

		Path = POINTER TO RECORD
			i, j: INTEGER; next: Path
		END;

		View = POINTER TO RECORD (Views.View)
			model: Model;
			i, j: INTEGER;
			d: INTEGER;
			font: Fonts.Font
		END;

		UpdateMsg = RECORD (Models.UpdateMsg) END;

	VAR 
		para*: RECORD
			nrOfAtoms*, boardSize*: INTEGER
		END;

		seed: INTEGER;

	PROCEDURE UniRand (): REAL;
		CONST a = 16807; m = 2147483647; q = m DIV a; r = m MOD a;
	BEGIN
		seed := a*(seed MOD q) - r*(seed DIV q);
		IF seed <= 0 THEN seed := seed + m END;
		RETURN seed * (1.0/m)
	END UniRand;

	(* problem-specific part *)

	PROCEDURE Atom (m: Model; i,j: INTEGER): BOOLEAN;
		VAR b: BYTE;
	BEGIN
		b := m.board[i,j]; RETURN (b = minded) OR (b = markedAndMinded)
	END Atom;

	PROCEDURE Marked (m: Model; i,j: INTEGER): BOOLEAN;
		VAR b: BYTE;
	BEGIN
		b := m.board[i,j]; RETURN (b = marked) OR (b = markedAndMinded)
	END Marked;

	PROCEDURE Shoot (m: Model; i1, j1: INTEGER);
		VAR i, j, d, di, dj : INTEGER;
	BEGIN
		IF j1 = 0 THEN di := 0; dj := 1
		ELSIF j1 = m.m+1 THEN di := 0; dj := -1
		ELSIF i1 = 0 THEN di := 1; dj := 0
		ELSIF i1 = m.m+1 THEN di := -1; dj := 0
		END; 
		i := i1; j := j1;
		IF ~Atom(m, i+di, j+dj) THEN
			REPEAT
				IF Atom(m, i+di+dj, j+di+dj) THEN d := di; di := -dj; dj := -d
				ELSIF Atom(m,i+di-dj, j-di+dj) THEN d := di; di := dj; dj := d
				ELSE i := i+di; j := j+dj
				END
			UNTIL (i=0) OR (i=m.m+1) OR (j=0) OR (j=m.m+1) OR Atom(m, i+di, j+dj);
			IF (i=0) OR (i=m.m+1) OR (j=0) OR (j=m.m+1) THEN
				IF (i = i1) & (j = j1) THEN m.board[i1, j1] := reflected
				ELSE INC(m.n); m.board[i,j] := SHORT(SHORT(m.n)); m.board[i1,j1] := SHORT(SHORT(m.n))
				END
			ELSE m.board[i1,j1] := absorbed
			END
		ELSE m.board[i1,j1] := absorbed
		END
	END Shoot;

	PROCEDURE GetPath (m: Model; i, j: INTEGER; VAR p: Path);
		VAR d, di, dj : INTEGER;

		PROCEDURE AddPoint(i, j: INTEGER); 
			VAR q: Path;
		BEGIN
			IF (p = NIL) OR (p.i # i) OR (p.j # j) THEN NEW(q); q.i := i; q.j := j; q.next := p; p := q END
		END AddPoint;

	BEGIN
		IF j = 0 THEN di := 0; dj := 1
		ELSIF j = m.m+1 THEN di := 0; dj := -1
		ELSIF i = 0 THEN di := 1; dj := 0
		ELSIF i = m.m+1 THEN di := -1; dj := 0
		END; 
		IF ~Atom(m, i+di, j+dj) THEN AddPoint(i, j);
			REPEAT
				IF Atom(m, i+di+dj, j+di+dj) THEN d := di; di := -dj; dj := -d; AddPoint(i, j)
				ELSIF Atom(m, i+di-dj, j-di+dj) THEN d := di; di := dj; dj := d; AddPoint(i, j)
				ELSE i := i+di; j := j+dj
				END;
			UNTIL (i = 0) OR (i = m.m+1) OR (j = 0) OR (j = m.m+1) OR Atom(m, i+di, j+dj);
			IF ~((i = 0) OR (i = m.m+1) OR (j = 0) OR (j = m.m+1)) THEN i := i+di; j := j+dj END;
			AddPoint(i, j)
		END
	END GetPath;

	PROCEDURE NewPuzzle (m: Model);
		VAR i, j, k: INTEGER;
	BEGIN
		FOR i := 0 TO m.m+1 DO FOR j := 0 TO m.m+1 DO m.board[i,j] := 0 END END;		
		k := 0;
		WHILE k < m.p DO
			i := 1 + SHORT(SHORT(ENTIER(UniRand()*m.m)));
			j := 1 + SHORT(SHORT(ENTIER(UniRand()*m.m)));
			IF ~Atom(m, i, j) THEN m.board[i,j] := minded; INC(k) END
		END
	END NewPuzzle;

	PROCEDURE Score (m: Model): INTEGER;
		VAR i, j, score, n: INTEGER;
	BEGIN
		score := 0; n := 0;
		FOR i := 0 TO m.m + 1 DO
			FOR j := 0 TO m.m + 1 DO
				IF (i = 0) OR (j = 0) OR (i = m.m+1) OR (j = m.m+1) THEN
					IF m.board[i,j] # 0 THEN INC(score) END
				ELSE
					IF Marked(m, i, j) THEN INC(n);
						IF ~Atom(m, i, j) THEN INC(score, 5) END
					END
				END
			END
		END;
		IF n < m.p THEN INC(score, 5 * (m.p - n)) END;
		RETURN score
	END Score;

	(* graphics part *)

	PROCEDURE DrawStringCentered (v: View; f: Ports.Frame; x, y: INTEGER; s: ARRAY OF CHAR);
		VAR asc, dsc, w: INTEGER;
	BEGIN
		v.font.GetBounds(asc, dsc, w);
		f.DrawString(x - v.font.StringWidth(s) DIV 2, y + asc DIV 2, Ports.black, s, v.font)
	END DrawStringCentered;

	PROCEDURE GetCoord (v: View; i, j: INTEGER; VAR x, y: INTEGER);
	BEGIN
		y := j * v.d + v.d DIV 2 + 1;
		x := i * v.d + v.d DIV 2 + 1;
		IF i = 0 THEN INC(x, v.d DIV 2)
		ELSIF i = v.model.m+1 THEN DEC(x, v.d DIV 2)
		ELSIF j = 0 THEN INC(y, v.d DIV 2)
		ELSIF j = v.model.m+1 THEN DEC(y, v.d DIV 2)
		END
	END GetCoord;

	(* Model *)

	PROCEDURE Init (m: Model);
	BEGIN
		m.m := para.boardSize; m.p := para.nrOfAtoms;
		NEW(m.board, m.m+2, m.m+2); NewPuzzle(m);
		m.n := 0; m.score := 0; m.showsol := FALSE
	END Init;

	PROCEDURE (m: Model) Externalize (VAR wr: Stores.Writer);
		VAR i, j: INTEGER;
	BEGIN
		wr.WriteVersion(maxVersion);
		wr.WriteInt(m.m);
		wr.WriteInt(m.p);
		wr.WriteInt(m.n);
		wr.WriteInt(m.score);
		wr.WriteBool(m.showsol);
		FOR i := 0 TO m.m+1 DO
			FOR j := 0 TO m.m+1 DO
				wr.WriteByte(m.board[i,j])
			END
		END
	END Externalize;

	PROCEDURE (m: Model) Internalize (VAR rd: Stores.Reader);
		VAR version: INTEGER; i, j: INTEGER;
	BEGIN
		rd.ReadVersion(minVersion, maxVersion, version);
		IF ~rd.cancelled THEN
			rd.ReadInt(m.m);
			rd.ReadInt(m.p);
			rd.ReadInt(m.n);
			rd.ReadInt(m.score);
			rd.ReadBool(m.showsol);
			NEW(m.board, m.m+2, m.m+2);
			FOR i := 0 TO m.m+1 DO
				FOR j := 0 TO m.m+1 DO
					rd.ReadByte(m.board[i,j])
				END
			END
		END
	END Internalize;

	PROCEDURE (m: Model) CopyFrom (source: Stores.Store);
		VAR i, j: INTEGER;
	BEGIN
		WITH source: Model DO
			Init(m);
			m.m := source.m; NEW(m.board, m.m+2, m.m+2);
			m.n := source.n; m.p := source.p;
			m.score := source.score; m.showsol := source.showsol;
			FOR i := 0 TO m.m+1 DO
				FOR j := 0 TO m.m+1 DO m.board[i,j] := source.board[i,j] END
			END
		END
	END CopyFrom;

	(* View *)

	PROCEDURE (v: View) Externalize (VAR wr: Stores.Writer);
	BEGIN
		wr.WriteVersion(maxVersion);
		wr.WriteInt(v.i);
		wr.WriteInt(v.j);
		wr.WriteStore(v.model)		
	END Externalize;

	PROCEDURE (v: View) Internalize (VAR rd: Stores.Reader);
		VAR version: INTEGER; st: Stores.Store;
	BEGIN
		rd.ReadVersion(minVersion, maxVersion, version);
		IF ~rd.cancelled THEN
			rd.ReadInt(v.i);
			rd.ReadInt(v.j);
			rd.ReadStore(st);
			v.model := st(Model);
			v.d := 0; 
			v.font := NIL
		END
	END Internalize;

	PROCEDURE (v: View) CopyFromModelView (source: Views.View; model: Models.Model);
	BEGIN
		ASSERT(model IS Model, 20);
		WITH source: View DO
			v.model := model(Model);
			v.i := source.i; v.j := source.j; v.d := source.d; v.font := source.font
		END
	END CopyFromModelView;

	PROCEDURE (v: View) ThisModel (): Models.Model;
	BEGIN
		RETURN v.model
	END ThisModel;

	PROCEDURE (v: View) Restore (f: Views.Frame; l, t, r, b: INTEGER);
		VAR w, h, d, x, y, x1, y1, asc, dsc, fw, i, j: INTEGER; p: Path; s: ARRAY 16 OF CHAR;
	BEGIN
		v.context.GetSize(w, h); d := w DIV (v.model.m + 2);
		IF (v.font = NIL) OR (v.d # d) THEN
			v.d := d; v.font := Fonts.dir.This("Chicago", d * 2 DIV 3, {}, Fonts.normal)
		END;

		FOR i := 1 TO v.model.m + 1 DO
			f.DrawLine(d, i * d,w - d, i * d, f.unit, 0);
			f.DrawLine(i * d, d, i * d,w - d, f.unit, 0)
		END;
		FOR i := 0 TO v.model.m + 1 DO
			FOR j := 0 TO v.model.m + 1 DO
				x := i * d + d DIV 2; y := j * d + d DIV 2;

				IF (i = 0) OR (i = v.model.m + 1) OR (j = 0) OR (j = v.model.m + 1) THEN
					IF v.model.board[i , j] = absorbed THEN DrawStringCentered(v, f, x, y, "A")
					ELSIF v.model.board[i , j] = reflected THEN DrawStringCentered(v, f, x, y, "R")
					ELSIF v.model.board[i, j] > 0 THEN
						Strings.IntToString(v.model.board[i, j], s); DrawStringCentered(v, f, x, y, s)
					END
				ELSE
					IF Marked(v.model, i, j) THEN r := (9 * d) DIV 20;
						f.DrawOval(x - r, y - r, x + r, y + r, Ports.fill, Ports.black)
					END;
					IF v.model.showsol & Atom(v.model, i, j) THEN r := d DIV 3;
						IF Marked(v.model, i, j) THEN f.DrawOval(x - r, y - r, x + r, y + r, Ports.fill, Ports.white)
						ELSE f.DrawOval(x - r, y - r, x + r, y + r, Ports.fill, Ports.black)
						END
					END
				END
			END
		END;
		IF (v.i > 0) OR (v.j > 0) THEN
			GetPath(v.model, v.i, v.j, p);
			IF p # NIL THEN
				GetCoord(v, p.i, p.j, x, y); p := p.next;
				WHILE p # NIL DO
					GetCoord(v, p.i, p.j, x1, y1);
					f.DrawLine(x, y, x1, y1, 2 * f.unit, 0); x := x1; y := y1; p := p.next
				END
			END
		END;
		Strings.IntToString(v.model.p, s);
		v.font.GetBounds(asc, dsc, fw);
		x := d; y := (v.model.m + 2) * d + (d + asc) DIV 2;
		f.DrawString(x, y, Ports.black, "Atoms: ", v.font);  x := x + v.font.StringWidth("Atoms: ");
		f.DrawString(x, y, Ports.black, s, v.font); 
		IF v.model.showsol THEN x := x + v.font.StringWidth(s);
			f.DrawString(x, y, Ports.black, "  Score: ", v.font); x := x + v.font.StringWidth("  Score: ");
			Strings.IntToString(v.model.score, s); f.DrawString(x, y, Ports.black, s, v.font)
		END
	END Restore;

	PROCEDURE Track (v: View; f: Views.Frame; x, y: INTEGER; buttons: SET);
		VAR i, j: INTEGER; msg: UpdateMsg;
	BEGIN
		i := SHORT(x DIV v.d); j := SHORT(y DIV v.d);
		IF (i > 0) & (i <= v.model.m) & (j > 0) & (j <= v.model.m) THEN	(* inside *)
			IF Marked(v.model, i, j) THEN INC(v.model.board[i, j], 4)
			ELSE DEC(v.model.board[i, j], 4) 
			END
		ELSIF ((i = 0) OR (i = v.model.m + 1)) & (j > 0) & (j <= v.model.m)
		OR ((j = 0) OR (j  = v.model.m + 1)) & (i > 0) & (i <= v.model.m) THEN
			IF v.model.board[i, j] = 0 THEN Shoot(v.model, i, j) END;
			IF v.model.showsol THEN
				IF Controllers.modify IN buttons THEN v.i := i; v.j := j ELSE v.i := 0; v.j := 0 END
			END
		END;
		Models.Broadcast(v.model, msg)
	END Track;

	PROCEDURE (v: View) HandleModelMsg (VAR msg: Models.Message);
		VAR w, h: INTEGER;
	BEGIN
		WITH msg: UpdateMsg DO
			IF ~v.model.showsol THEN v.i := 0; v.j := 0 END;	(* adjust view to change of model *)
			v.context.GetSize(w, h); Views.UpdateIn(v, 0, 0, w, h,  Views.keepFrames)
		ELSE
		END
	END HandleModelMsg;

	PROCEDURE (v: View) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message;
																				VAR focus: Views.View);
	BEGIN
		WITH msg: Controllers.TrackMsg DO
			(* Views.BeginModification(Views.unundoableOp, v); *)
			Track(v, f, msg.x, msg.y, msg.modifiers); Views.SetDirty(v)
			(* Views.EndModification(Views.unundoableOp, v) *)
		| msg: Controllers.PollOpsMsg DO
			msg.type := "ObxBlackBox.View"
		ELSE
		END
	END HandleCtrlMsg;

	PROCEDURE (v: View) HandlePropMsg (VAR msg: Properties.Message);
	BEGIN
		WITH msg: Properties.SizePref DO
			IF (msg.w > Views.undefined) & (msg.h > Views.undefined) THEN
				Properties.ProportionalConstraint(v.model.m, v.model.m + 1, msg.fixedW, msg.fixedH, msg.w, msg.h)
			ELSE
				msg.w := 100 * Ports.mm; msg.h := msg.w * (v.model.m + 1) DIV v.model.m;
			END;
		| msg: Properties.FocusPref DO
			msg.setFocus := TRUE
		ELSE
		END
	END HandlePropMsg;

	(* commands *)

	PROCEDURE Deposit*;
		VAR v: View; m: Model;
	BEGIN
		NEW(m); Init(m);
		NEW(v); v.model := m; Stores.Join(v, m);
		Views.Deposit(v)
	END Deposit;

	PROCEDURE ShowSolution*;
		VAR v : Views.View; msg: UpdateMsg;
	BEGIN
		v := Controllers.FocusView();
		IF v # NIL THEN
			WITH v: View DO
				(* Views.BeginModification(v); *)
				v.model.showsol := TRUE; v.model.score := Score(v.model);
				Models.Broadcast(v.model, msg);
				(* Views.EndModification(v) *)
			END
		END
	END ShowSolution;

	PROCEDURE ShowSolutionGuard* (VAR par: Dialog.Par);
		VAR v: Views.View;
	BEGIN
		v := Controllers.FocusView();
		par.disabled := (v = NIL) OR ~(v IS View) OR v(View).model.showsol
	END ShowSolutionGuard;

	PROCEDURE New*;
		VAR v: Views.View; msg: UpdateMsg;
	BEGIN
		v := Controllers.FocusView();
		IF v # NIL THEN
			WITH v: View DO
				(* Views.BeginModification(v); *)
				NewPuzzle(v.model);
				v.model.n := 0; v.model.score := 0; v.model.showsol := FALSE;
				v.i := 0; v.j := 0;
				Models.Broadcast(v.model, msg);
				(* Views.EndModification(v) *)
			END
		END		
	END New;

	PROCEDURE Set*;
		VAR v : Views.View; msg: UpdateMsg; i, j: INTEGER;
	BEGIN
		v := Controllers.FocusView();
		IF v # NIL THEN
			WITH v: View DO
				(* Views.BeginModification(v); *)
				v.model.p := 0;
				FOR i := 0 TO v.model.m + 1 DO
					FOR j := 0 TO v.model.m + 1 DO
						IF Marked(v.model, i, j) THEN INC(v.model.p); v.model.board[i,j] := minded
						ELSE v.model.board[i,j] := 0
						END
					END
				END;
				v.model.n := 0; v.model.score := 0; v.model.showsol := FALSE;
				v.i := 0; v.j := 0;
				Models.Broadcast(v.model, msg);
				(* Views.EndModification(v) *)
			END
		END		
	END Set;

BEGIN
	seed := SHORT(Services.Ticks()); para.boardSize := 8; para.nrOfAtoms := 4
END ObxBlackBox.