home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga MA Magazine 1998 #6
/
amigamamagazinepolishissue1998.iso
/
coders
/
jËzyki_programowania
/
oberon
/
system
/
keplergraphs.mod
(
.txt
)
< prev
next >
Wrap
Oberon Text
|
1977-12-31
|
17KB
|
545 lines
Syntax10.Scn.Fnt
MODULE KeplerGraphs; (* J. Templ, 30.10.90 *)
IMPORT SYSTEM, KeplerPorts, Display, Files, Oberon, Modules, Types, Texts;
CONST
draw* = 0; restore* = 1; (* notify op-codes *)
ptSize = 12;
maxNofpts = 4;
(* graph = {star} {configuration} 0X.
star = header contents.
configuration = header contents.
header = typeref [typename].
typeref = compact-integer.
typename = qualident 0X.
contents = {byte}. *)
TYPE
Object* = POINTER TO ObjectDesc;
ObjectDesc* = RECORD END ;
Star* = POINTER TO StarDesc;
StarDesc* = RECORD
(ObjectDesc)
x*, y*, refcnt*, ref: INTEGER;
sel*: BOOLEAN;
next* : Star;
END ;
Constellation* = POINTER TO ConsDesc;
ConsDesc* = RECORD
(ObjectDesc)
nofpts*: INTEGER;
p*: ARRAY maxNofpts OF Star;
next*: Constellation;
END ;
Planet* = POINTER TO PlanetDesc;
PlanetDesc* = RECORD
(StarDesc)
c*: Constellation;
END;
Graph* = POINTER TO GraphDesc;
Notifier* = PROCEDURE (op: INTEGER; G: Graph; O: Object; P: KeplerPorts.Port);
GraphDesc* = RECORD
(ObjectDesc)
cons*, lastcons: Constellation;
stars*, laststar: Star;
seltime*: LONGINT;
notify*: Notifier;
END ;
StarTab = POINTER TO ARRAY OF LONGINT;
loading*: Graph;
update: KeplerPorts.BalloonPort;
nofpt: INTEGER;
starTab: StarTab;
noftypes: LONGINT;
typTab: ARRAY 256 OF LONGINT;
del, delG: Graph;
(* ---------------------------------- abstract methods ---------------------------------- *)
PROCEDURE (self: Object) Draw* (P: KeplerPorts.Port);
END Draw;
PROCEDURE (self: Object) Read* (VAR R: Files.Rider);
END Read;
PROCEDURE (self: Object) Write* (VAR R: Files.Rider);
END Write;
(* ---------------------------------- auxiliary procedures ---------------------------------- *)
PROCEDURE err(s0, s1: ARRAY OF CHAR);
VAR W: Texts.Writer;
BEGIN Texts.OpenWriter(W);
Texts.WriteString(W, s0); Texts.WriteString(W, s1); Texts.WriteLn(W);
Texts.Append(Oberon.Log, W.buf)
END err;
PROCEDURE err2(s0, s1: ARRAY OF CHAR);
VAR W: Texts.Writer;
BEGIN Texts.OpenWriter(W);
Texts.WriteString(W, s0); Texts.WriteString(W, s1);
Texts.Append(Oberon.Log, W.buf)
END err2;
PROCEDURE ReadObj* (VAR R: Files.Rider; VAR x: Object);
VAR ref: LONGINT;
m: Modules.Module; t: Types.Type;
module, type: ARRAY 32 OF CHAR;
BEGIN x := NIL;
Files.ReadNum(R, ref);
IF ref = noftypes THEN
Files.ReadString(R, module);
Files.ReadString(R, type);
m := Modules.ThisMod(module);
IF m # NIL THEN t := Types.This(m, type);
IF t # NIL THEN typTab[ref] := SYSTEM.VAL(LONGINT, t); INC(noftypes);
Types.NewObj(x, t); x.Read(R)
ELSE err("-- type not found: ", type)
END
ELSE err2("-- error: ", Modules.importing);
IF Modules.res = 2 THEN err(" not an obj-file", "")
ELSIF Modules.res = 3 THEN err2(" imports ", Modules.imported); err(" with bad key", "");
ELSIF Modules.res = 4 THEN err(" corrupted obj file", "")
ELSIF Modules.res = 7 THEN err(" not enough space", "")
END;
(*Modules.res := 0*)
END
ELSIF ref # -1 THEN
Types.NewObj(x, SYSTEM.VAL(Types.Type, typTab[ref]));
x.Read(R)
END
END ReadObj;
PROCEDURE WriteObj* (VAR R: Files.Rider; x: Object);
VAR typ: Types.Type; i: LONGINT;
BEGIN
IF x # NIL THEN
typ := Types.TypeOf(x); i := 0;
WHILE (i < noftypes) & (SYSTEM.VAL(LONGINT, typ) # typTab[i]) DO INC(i) END ;
IF i = noftypes THEN
Files.WriteNum(R, i);
typTab[i] := SYSTEM.VAL(LONGINT, typ); INC(noftypes);
Files.WriteString(R, typ.module.name);
Files.WriteString(R, typ.name)
ELSE
Files.WriteNum(R, i)
END ;
x.Write(R)
ELSE Files.WriteNum(R, -1)
END
END WriteObj;
PROCEDURE GetType* (o: Object; VAR module, type: ARRAY OF CHAR);
VAR t: Types.Type;
BEGIN t := Types.TypeOf(o); COPY(t.module.name, module); COPY(t.name, type)
END GetType;
PROCEDURE Reset*;
BEGIN nofpt := 0; noftypes := 0
END Reset;
PROCEDURE GetStar (n: INTEGER): Star;
VAR s: Star;
BEGIN s := SYSTEM.VAL(Star, starTab[n]); INC(s.refcnt); RETURN s
END GetStar;
(* ---------------------------------- Star methods ---------------------------------- *)
PROCEDURE (self: Star) Draw* (P: KeplerPorts.Port);
BEGIN
IF self.sel THEN
P.FillRect(self.x - ptSize, self.y - ptSize, ptSize*2 + P.scale, ptSize*2 + P.scale, Display.white, 5, Display.invert)
END
END Draw;
PROCEDURE (self: Star) Read* (VAR R: Files.Rider);
VAR h: LONGINT;
BEGIN self.sel := FALSE;
Files.ReadNum(R, h); self.x := SHORT(h);
Files.ReadNum(R, h); self.y := SHORT(h)
END Read;
PROCEDURE (self: Star) Write* (VAR R: Files.Rider);
BEGIN
Files.WriteNum(R, self.x);
Files.WriteNum(R, self.y)
END Write;
(* ---------------------------------- Constellation methods ---------------------------------- *)
PROCEDURE (self: Constellation) State* (): INTEGER; (* unselected = 0; partially selected = 1; totally selected = 2 *)
VAR sum, i: INTEGER;
BEGIN sum := 0; i := 0;
WHILE i < self.nofpts DO
IF self.p[i].sel THEN INC(sum) END ;
INC(i)
END ;
IF sum = 0 THEN RETURN 0
ELSIF sum = self.nofpts THEN RETURN 2
ELSE RETURN 1
END
END State;
PROCEDURE (self: Constellation) Read* (VAR R: Files.Rider);
VAR ref, i: LONGINT;
BEGIN i := 0;
Files.ReadNum(R, ref); self.nofpts := SHORT(ref);
i := 0;
WHILE i < self.nofpts DO
Files.ReadNum(R, ref);
self.p[i] := GetStar(SHORT(ref));
INC(i)
END
END Read;
PROCEDURE (self: Constellation) Write* ( VAR R: Files.Rider);
VAR i: INTEGER;
BEGIN i := 0;
Files.WriteNum(R, self.nofpts);
WHILE i < self.nofpts DO Files.WriteNum(R, self.p[i].ref); INC(i) END
END Write;
(* ---------------------------------- Planet methods ---------------------------------- *)
PROCEDURE (self: Planet) Draw* (P: KeplerPorts.Port);
BEGIN
IF self.sel THEN
P.DrawRect(self.x - ptSize, self.y - ptSize, ptSize*2, ptSize*2, Display.white, Display.invert)
END
END Draw;
PROCEDURE (self: Planet) Calc*;
END Calc;
PROCEDURE (self: Planet) Read* (VAR R: Files.Rider);
VAR o: Object;
BEGIN self.Read^(R); ReadObj(R, o); self.c := o(Constellation)
END Read;
PROCEDURE (self: Planet) Write* (VAR R: Files.Rider);
BEGIN self.Write^(R); WriteObj(R, self.c)
END Write;
(* ---------------------------------- Graphic methods ---------------------------------- *)
PROCEDURE (G: Graph) Append*(o: Object);
BEGIN
IF o IS Star THEN
WITH o: Star DO
IF G.stars = NIL THEN G.stars := o ELSE G.laststar.next := o END ;
G.laststar := o; o.next := NIL
END
ELSE
WITH o: Constellation DO
IF G.cons = NIL THEN G.cons := o ELSE G.lastcons.next := o END ;
G.lastcons := o; o.next := NIL;
G.notify(draw, G, o, NIL)
END
END
END Append;
PROCEDURE (G: Graph) FlipSelection*(p: Star);
BEGIN
IF p.sel THEN G.notify(draw, G, p, NIL); p.sel := FALSE
ELSE p.sel := TRUE; G.notify(draw, G, p, NIL); G.seltime := Oberon.Time()
END
END FlipSelection;
PROCEDURE DependsOn(c: Constellation; s: Star): BOOLEAN;
VAR i: INTEGER; p: Star;
BEGIN i := 0;
WHILE i < c.nofpts DO p := c.p[i];
IF p = s THEN RETURN TRUE
ELSIF (p IS Planet) & DependsOn(p(Planet).c, s) THEN RETURN TRUE
END ;
INC(i)
END ;
RETURN FALSE
END DependsOn;
PROCEDURE (G: Graph) Move*(s: Star; dx, dy: INTEGER);
VAR p: Star; c: Constellation;
BEGIN
KeplerPorts.InitBalloon(update);
c := G.cons;
WHILE c # NIL DO
IF DependsOn(c, s) THEN c.Draw(update) END ;
c := c.next
END ;
p := s^.next;
WHILE p # NIL DO
IF (p IS Planet) & DependsOn(p(Planet).c, s) THEN p.Draw(update) END ;
p := p.next
END ;
s.Draw(update); INC(s.x, dx); INC(s.y, dy); s.Draw(update);
p := s^.next;
WHILE p # NIL DO
IF (p IS Planet) & DependsOn(p(Planet).c, s) THEN p(Planet).Calc; p.Draw(update) END ;
p := p.next
END ;
c := G.cons;
WHILE c # NIL DO
IF DependsOn(c, s) THEN c.Draw(update) END ;
c := c.next
END ;
G.notify(restore, G, NIL, update)
END Move;
PROCEDURE (G: Graph) MoveSelection*(dx, dy: INTEGER);
VAR p: Star; c: Constellation;
BEGIN
KeplerPorts.InitBalloon(update);
p := G.stars;
WHILE p # NIL DO (*expand selection*)
IF ~p.sel & (p IS Planet) & (p(Planet).c.State() > 0) THEN p.sel := TRUE END ;
p := p.next
END ;
c := G.cons;
WHILE c # NIL DO
IF c.State() # 0 THEN c.Draw(update) END ;
c := c.next
END ;
p := G.stars;
WHILE p # NIL DO
IF p.sel THEN
p.Draw(update);
IF p IS Planet THEN p(Planet).Calc
ELSE INC(p.x, dx); INC(p.y, dy)
END ;
p.Draw(update)
END ;
p := p.next
END ;
c := G.cons;
WHILE c # NIL DO
IF c.State() # 0 THEN c.Draw(update) END ;
c := c.next
END ;
G.notify(restore, G, NIL, update)
END MoveSelection;
PROCEDURE ReverseStars(G: Graph);
VAR p, first, next: Star;
BEGIN p := G.stars;
G.laststar := p; first := NIL;
WHILE p # NIL DO
next := p.next; p.next := first;
first := p; p := next
END ;
G.stars := first
END ReverseStars;
PROCEDURE Release (self: Constellation);
VAR i: INTEGER; s: Star;
BEGIN i := 0;
WHILE i < self.nofpts DO s := self.p[i]; DEC(s.refcnt); INC(i) END
END Release;
PROCEDURE CutCons (G: Graph; prevc, c: Constellation);
BEGIN
IF prevc = NIL THEN G.cons := c.next ELSE prevc.next := c.next END ;
IF del.cons = NIL THEN del.cons := c ELSE del.lastcons.next := c END ;
del.lastcons := c;
IF G.lastcons = c THEN G.lastcons:= prevc END ;
Release(c); c.Draw(update)
END CutCons;
PROCEDURE CutStar (G:Graph; prevs, s: Star);
BEGIN
IF prevs = NIL THEN G.stars := s.next ELSE prevs.next := s.next END ;
IF del.stars = NIL THEN del.stars := s ELSE del.laststar.next := s END ;
del.laststar := s;
IF G.laststar = s THEN G.laststar := prevs END ;
IF s IS Planet THEN Release(s(Planet).c) END ;
s.ref := 0;
s.Draw(update)
END CutStar;
PROCEDURE DelStar(G: Graph; o: Object);
VAR s, prevs: Star;
BEGIN
s := G.stars; prevs := NIL;
WHILE (s # NIL) & (s # o) DO prevs := s; s := s.next END ;
IF s # NIL THEN CutStar(G, prevs, s) END
END DelStar;
PROCEDURE (G: Graph) Delete* (o: Object);
VAR c, prevc: Constellation; i: INTEGER;
BEGIN
KeplerPorts.InitBalloon(update);
delG := G; del.cons := NIL; del.stars := NIL;
IF o IS Constellation THEN
c := G.cons; prevc := NIL;
WHILE (c # NIL) & (c # o) DO prevc := c; c := c.next END ;
IF c # NIL THEN
CutCons(G, prevc, c); i := 0;
WHILE i < c.nofpts DO
IF (c.p[i].refcnt = 0) & ~(c.p[i] IS Planet) THEN DelStar(G, c.p[i]) END ;
INC(i)
END
END
ELSE ASSERT(o(Star).refcnt = 0);
IF o IS Planet THEN
c := o(Planet).c; Release(c); i := 0;
WHILE i < c.nofpts DO
IF (c.p[i].refcnt = 0) & ~(c.p[i] IS Planet) THEN DelStar(G, c.p[i]) END ;
INC(i)
END
END ;
DelStar(G, o)
END ;
IF del.cons # NIL THEN del.lastcons.next := NIL END ;
IF del.stars # NIL THEN del.laststar.next := NIL END ;
G.notify(restore, G, NIL, update)
END Delete;
PROCEDURE (G: Graph) DeleteSelection* (minstate: INTEGER);
VAR s, prevs: Star; c, prevc: Constellation;
BEGIN
delG := G; KeplerPorts.InitBalloon(update);
(*move all constellations with (State >= minstate) into del buffer*)
c := G.cons; prevc := NIL; del.cons := NIL;
WHILE c # NIL DO
IF c.State() >= minstate THEN CutCons(G, prevc, c) ELSE prevc := c END ;
c := c.next
END ;
IF del.cons # NIL THEN del.lastcons.next := NIL END ;
(*move all unused stars and planets with refcnt=0 & c.State>=minstate into del buffer*)
ReverseStars(G);
s := G.stars; prevs := NIL; del.stars := NIL;
WHILE s # NIL DO
IF (s.refcnt = 0) & (~(s IS Planet) OR s.sel OR (s(Planet).c.State() >= minstate)) THEN CutStar(G, prevs, s)
ELSE prevs := s
END ;
s := s.next
END ;
ReverseStars(G) ;
IF del.stars # NIL THEN del.laststar.next := NIL; ReverseStars(del) END ;
G.notify(restore, G, NIL, update)
END DeleteSelection;
PROCEDURE (G: Graph) All* (op: INTEGER); (* deselect = 0; select = 1 *)
VAR p: Star;
BEGIN p := G.stars;
KeplerPorts.InitBalloon(update);
WHILE p # NIL DO
IF (op = 1) # p.sel THEN
IF p.sel THEN p.Draw(update); p.sel := FALSE
ELSE p.sel := TRUE; p.Draw(update); G.seltime := Oberon.Time()
END
END ;
p := p.next
END ;
IF op = 0 THEN G.seltime := -1 END ;
G.notify(restore, G, NIL, update)
END All;
PROCEDURE Store(G: Graph; VAR R: Files.Rider; all: BOOLEAN);
VAR p, dummy: Star; c: Constellation;
BEGIN
p := G.stars;
NEW(dummy);
WHILE p # NIL DO
IF all OR (p.sel & ~(p IS Planet)) THEN
WriteObj(R, p); p.ref := nofpt; INC(nofpt)
ELSIF p.sel & (p(Planet).c.State() = 2) THEN
WriteObj(R, p); p.ref := nofpt; INC(nofpt)
ELSIF p.sel & (p(Planet).c.State() # 2) THEN
dummy^ := p^; WriteObj(R, dummy); p.ref := nofpt; INC(nofpt)
END ;
p := p.next
END ;
c := G.cons;
WHILE c # NIL DO
IF all OR (c.State()=2) THEN WriteObj(R, c) END ;
c := c.next
END ;
Files.WriteNum(R, -1)
END Store;
PROCEDURE (G: Graph) Draw* (P: KeplerPorts.Port);
VAR s: Star; c: Constellation;
BEGIN
c := G.cons;
WHILE c # NIL DO c.Draw(P); c := c.next END ;
s := G.stars;
WHILE s # NIL DO s.Draw(P); s := s.next END
END Draw;
PROCEDURE (G: Graph) Write* (VAR R: Files.Rider);
BEGIN
Store(G, R, TRUE)
END Write;
PROCEDURE (G: Graph) WriteSel* (VAR R: Files.Rider);
BEGIN Store(G, R, FALSE)
END WriteSel;
PROCEDURE DoubleStarTab;
VAR h: StarTab; i: LONGINT;
BEGIN i := 0; NEW(h, LEN(starTab^)*2);
WHILE i < LEN(starTab^) DO h[i] := starTab[i]; INC(i) END ;
starTab := h
END DoubleStarTab;
PROCEDURE (G: Graph) Read* (VAR R: Files.Rider);
VAR o, o0: Object;
BEGIN loading := G;
G.stars := NIL; G.laststar := NIL; G.cons := NIL; G.lastcons := NIL; G.seltime := -1;
ReadObj(R, o0); o := o0;
WHILE o # NIL DO (* append without notification *)
WITH o: Star DO
IF G.stars = NIL THEN G.stars := o ELSE G.laststar.next := o END ;
G.laststar := o; o.next := NIL;
IF nofpt = LEN(starTab^) THEN DoubleStarTab END ;
starTab[nofpt] := SYSTEM.VAL(LONGINT, o); INC(nofpt)
| o: Constellation DO
IF G.cons = NIL THEN G.cons := o ELSE G.lastcons.next := o END ;
G.lastcons := o; o.next := NIL
END ;
ReadObj(R, o)
END
END Read;
PROCEDURE Old*(name: ARRAY OF CHAR): Graph;
VAR F: Files.File; R: Files.Rider; o: Object;
BEGIN F := Files.Old(name);
IF F # NIL THEN Files.Set(R, F, 0); Reset; ReadObj(R, o);
IF R.res = 0 THEN RETURN o(Graph) ELSE RETURN NIL END
ELSE RETURN NIL
END
END Old;
PROCEDURE *Dummy(op: INTEGER; g: Graph; c: Object; f: KeplerPorts.Port);
END Dummy;
PROCEDURE (G: Graph) CopySelection* (from: Graph; dx, dy: INTEGER);
VAR cpBuf: Files.File;
R: Files.Rider;
c, nextc: Constellation;
p, nextp: Star;
buf: Graph;
BEGIN
cpBuf := Files.New("");
Files.Set(R, cpBuf, 0);
Reset; from.WriteSel(R);
Files.Set(R, cpBuf, 0); Types.NewObj(buf, Types.TypeOf(from)); buf.notify := Dummy;
Reset; buf.Read(R);
p := buf.stars;
WHILE p # NIL DO nextp := p.next;
INC(p.x, dx); INC(p.y, dy);
IF (p.refcnt > 0) OR (p IS Planet) THEN G.Append(p) END;
p := nextp
END ;
c := buf.cons; KeplerPorts.InitBalloon(update);
WHILE c # NIL DO c.Draw(update); nextc := c.next;
IF G.cons = NIL THEN G.cons := c ELSE G.lastcons.next := c END ;
G.lastcons := c; c.next := NIL;
c := nextc
END ;
G.notify(restore, G, NIL, update)
END CopySelection;
PROCEDURE (G: Graph) SendToBack* (o: Object);
VAR i: INTEGER;
s: Star;
c: Constellation;
BEGIN
WITH
o: Star DO
s := G.stars;
IF o # s THEN
WHILE s.next # o DO s := s.next END ;
s.next := o.next; o.next := G.stars; G.stars := o;
IF G.laststar = o THEN G.laststar := s END ;
IF o IS Planet THEN (* preserve topological order *)
c := o(Planet).c;
FOR i := 0 TO c.nofpts-1 DO
G.SendToBack(c.p[i])
END
END
END
| o: Constellation DO
KeplerPorts.InitBalloon(update);
c := G.cons;
IF o # c THEN
WHILE c.next # o DO c := c.next END ;
c.next := o.next; o.next := G.cons; G.cons := o;
IF G.lastcons = o THEN G.lastcons := c END ;
o.Draw(update);
G.notify(restore, G, NIL, update)
END
END
END SendToBack;
PROCEDURE Unrelease(c: Constellation);
VAR i: INTEGER;
BEGIN i := 0;
WHILE i < c.nofpts DO INC(c.p[i].refcnt); INC(i) END
END Unrelease;
PROCEDURE Recall*;
VAR s, nexts: Star; c, nextc: Constellation;
BEGIN
IF delG # NIL THEN
s := del.stars;
WHILE s # NIL DO
nexts := s.next; s.sel := FALSE; delG.Append(s);
IF s IS Planet THEN Unrelease(s(Planet).c) END ;
s := nexts
END ;
c := del.cons;
WHILE c # NIL DO nextc := c.next; delG.Append(c); Unrelease(c); c := nextc END ;
delG := NIL; del.cons := NIL; del.lastcons := NIL; del.stars := NIL; del.laststar := NIL
END
END Recall;
BEGIN NEW(update); NEW(del); NEW(starTab, 1)
END KeplerGraphs.