Trurl-based/System/Mod/Properties.txt

   1 MODULE Properties;
   2
   3         (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Properties.odc *)
   4         (* DO NOT EDIT *)
   5
   6         IMPORT SYSTEM, Kernel, Math, Services, Fonts, Stores, Views, Controllers, Dialog;
   7
   8         CONST
   9                 (** StdProp.known/valid **)
  10                 color* = 0; typeface* = 1; size* = 2; style* = 3; weight* = 4;
  11
  12                 (** SizeProp.known/valid **)
  13                 width* = 0; height* = 1;
  14
  15                 (** PollVerbsMsg limitation **)
  16                 maxVerbs* = 16;
  17
  18                 (** PollPickMsg.mark, PollPick mark **)
  19                 noMark* = FALSE; mark* = TRUE;
  20                 (** PollPickMsg.show, PollPick show **)
  21                 hide* = FALSE; show* = TRUE;
  22
  23
  24         TYPE
  25                 Property* = POINTER TO ABSTRACT RECORD
  26                         next-: Property;        (** property lists are sorted **)       (* by TD address *)
  27                         known*, readOnly*: SET; (** used for polling, ignored when setting properties **)
  28                         valid*: SET
  29                 END;
  30
  31                 StdProp* = POINTER TO RECORD (Property)
  32                         color*: Dialog.Color;
  33                         typeface*: Fonts.Typeface;
  34                         size*: INTEGER;
  35                         style*: RECORD val*, mask*: SET END;
  36                         weight*: INTEGER
  37                 END;
  38
  39                 SizeProp* = POINTER TO RECORD (Property)
  40                         width*, height*: INTEGER
  41                 END;
  42
  43
  44                 (** property messages **)
  45
  46                 Message* = Views.PropMessage;
  47
  48                 PollMsg* = RECORD (Message)
  49                         prop*: Property (** preset to NIL **)
  50                 END;
  51
  52                 SetMsg* = RECORD (Message)
  53                         old*, prop*: Property
  54                 END;
  55
  56
  57                 (** preferences **)
  58
  59                 Preference* = ABSTRACT RECORD (Message) END;
  60
  61                 ResizePref* = RECORD (Preference)
  62                         fixed*: BOOLEAN;        (** OUT, preset to FALSE **)
  63                         horFitToPage*: BOOLEAN; (** OUT, preset to FALSE **)
  64                         verFitToPage*: BOOLEAN; (** OUT, preset to FALSE **)
  65                         horFitToWin*: BOOLEAN;  (** OUT, preset to FALSE **)
  66                         verFitToWin*: BOOLEAN;  (** OUT, preset to FALSE **)
  67                 END;
  68
  69                 SizePref* = RECORD (Preference)
  70                         w*, h*: INTEGER;        (** OUT, preset to caller's preference **)
  71                         fixedW*, fixedH*: BOOLEAN       (** IN **)
  72                 END;
  73
  74                 BoundsPref* = RECORD (Preference)
  75                         w*, h*: INTEGER (** OUT, preset to (Views.undefined, Views.undefined) **)
  76                 END;
  77
  78                 FocusPref* = RECORD (Preference)
  79                         atLocation*: BOOLEAN;   (** IN **)
  80                         x*, y*: INTEGER;        (** IN, valid iff atLocation **)
  81                         hotFocus*, setFocus*: BOOLEAN   (** OUT, preset to (FALSE, FALSE) **)
  82                 END;
  83
  84                 ControlPref* = RECORD (Preference)
  85                         char*: CHAR;    (** IN **)
  86                         focus*: Views.View;     (** IN **)
  87                         getFocus*: BOOLEAN;     (** OUT, valid if (v # focus), preset to ((char = [l]tab) & "FocusPref.setFocus") **)
  88                         accepts*: BOOLEAN       (** OUT, preset to ((v = focus) & (char # [l]tab)) **)
  89                 END;
  90
  91                 TypePref* = RECORD (Preference)
  92                         type*: Stores.TypeName; (** IN **)
  93                         view*: Views.View       (** OUT, preset to NIL **)
  94                 END;
  95
  96
  97                 (** verbs **)
  98
  99                 PollVerbMsg* = RECORD (Message)
 100                         verb*: INTEGER; (** IN **)
 101                         label*: ARRAY 64 OF CHAR;       (** OUT, preset to "" **)
 102                         disabled*, checked*: BOOLEAN    (** OUT, preset to FALSE, FALSE **)
 103                 END;
 104
 105                 DoVerbMsg* = RECORD (Message)
 106                         verb*: INTEGER; (** IN **)
 107                         frame*: Views.Frame     (** IN **)
 108                 END;
 109
 110
 111                 (** controller messages **)
 112
 113                 CollectMsg* = RECORD (Controllers.Message)
 114                         poll*: PollMsg  (** OUT, preset to NIL **)
 115                 END;
 116
 117                 EmitMsg* = RECORD (Controllers.RequestMessage)
 118                         set*: SetMsg    (** IN **)
 119                 END;
 120
 121
 122                 PollPickMsg* = RECORD (Controllers.TransferMessage)
 123                         mark*: BOOLEAN; (** IN, request to mark pick target **)
 124                         show*: BOOLEAN; (** IN, if mark then show/hide target mark **)
 125                         dest*: Views.Frame      (** OUT, preset to NIL, set if PickMsg is acceptable **)
 126                 END;
 127
 128                 PickMsg* = RECORD (Controllers.TransferMessage)
 129                         prop*: Property (** set to picked properties by destination **)
 130                 END;
 131
 132
 133         VAR era-: INTEGER;      (* estimator to cache standard properties of focus *)
 134
 135
 136         PROCEDURE ^ IntersectSelections* (a, aMask, b, bMask: SET; OUT c, cMask: SET; OUT equal: BOOLEAN);
 137
 138
 139         (** properties **)
 140
 141         PROCEDURE (p: Property) IntersectWith* (q: Property; OUT equal: BOOLEAN), NEW, ABSTRACT;
 142
 143         PROCEDURE (p: StdProp) IntersectWith* (q: Property; OUT equal: BOOLEAN);
 144                 VAR valid: SET; c, m: SET; eq: BOOLEAN;
 145         BEGIN
 146                 WITH q: StdProp DO
 147                         valid := p.valid * q.valid; equal := TRUE;
 148                         IF p.color.val # q.color.val THEN EXCL(valid, color) END;
 149                         IF p.typeface # q.typeface THEN EXCL(valid, typeface) END;
 150                         IF p.size # q.size THEN EXCL(valid, size) END;
 151                         IntersectSelections(p.style.val, p.style.mask, q.style.val, q.style.mask, c, m, eq);
 152                         IF m = {} THEN EXCL(valid, style)
 153                         ELSIF (style IN valid) & ~eq THEN p.style.mask := m; equal := FALSE
 154                         END;
 155                         IF p.weight # q.weight THEN EXCL(valid, weight) END;
 156                         IF p.valid # valid THEN p.valid := valid; equal := FALSE END
 157                 END
 158         END IntersectWith;
 159
 160         PROCEDURE (p: SizeProp) IntersectWith* (q: Property; OUT equal: BOOLEAN);
 161                 VAR valid: SET;
 162         BEGIN
 163                 WITH q: SizeProp DO
 164                         valid := p.valid * q.valid; equal := TRUE;
 165                         IF p.width # q.width THEN EXCL(valid, width) END;
 166                         IF p.height # q.height THEN EXCL(valid, height) END;
 167                         IF p.valid # valid THEN p.valid := valid; equal := FALSE END
 168                 END
 169         END IntersectWith;
 170
 171
 172         (** property collection and emission **)
 173
 174         PROCEDURE IncEra*;
 175         BEGIN
 176                 INC(era)
 177         END IncEra;
 178
 179
 180         PROCEDURE CollectProp* (OUT prop: Property);
 181                 VAR msg: CollectMsg;
 182         BEGIN
 183                 msg.poll.prop := NIL;
 184                 Controllers.Forward(msg);
 185                 prop := msg.poll.prop
 186         END CollectProp;
 187
 188         PROCEDURE CollectStdProp* (OUT prop: StdProp);
 189         (** post: prop # NIL, prop.style.val = prop.style.val * prop.style.mask **)
 190                 VAR p: Property;
 191         BEGIN
 192                 CollectProp(p);
 193                 WHILE (p # NIL) & ~(p IS StdProp) DO p := p.next END;
 194                 IF p # NIL THEN
 195                         prop := p(StdProp); prop.next := NIL
 196                 ELSE
 197                         NEW(prop); prop.known := {}
 198                 END;
 199                 prop.valid := prop.valid * prop.known;
 200                 prop.style.val := prop.style.val * prop.style.mask
 201         END CollectStdProp;
 202
 203         PROCEDURE EmitProp* (old, prop: Property);
 204                 VAR msg: EmitMsg;
 205         BEGIN
 206                 IF prop # NIL THEN
 207                         msg.set.old := old; msg.set.prop := prop;
 208                         Controllers.Forward(msg)
 209                 END
 210         END EmitProp;
 211
 212
 213         PROCEDURE PollPick* (x, y: INTEGER;
 214                                                         source: Views.Frame; sourceX, sourceY: INTEGER;
 215                                                         mark, show: BOOLEAN;
 216                                                         OUT dest: Views.Frame; OUT destX, destY: INTEGER);
 217                 VAR msg: PollPickMsg;
 218         BEGIN
 219                 ASSERT(source # NIL, 20);
 220                 msg.mark := mark; msg.show := show; msg.dest := NIL;
 221                 Controllers.Transfer(x, y, source, sourceX, sourceY, msg);
 222                 dest := msg.dest; destX := msg.x; destY := msg.y
 223         END PollPick;
 224
 225         PROCEDURE Pick* (x, y: INTEGER; source: Views.Frame; sourceX, sourceY: INTEGER;
 226                                                         OUT prop: Property);
 227                 VAR msg: PickMsg;
 228         BEGIN
 229                 ASSERT(source # NIL, 20);
 230                 msg.prop := NIL;
 231                 Controllers.Transfer(x, y, source, sourceX, sourceY, msg);
 232                 prop := msg.prop
 233         END Pick;
 234
 235
 236         (** property list construction **)
 237
 238         PROCEDURE Insert* (VAR list: Property; x: Property);
 239                 VAR p, q: Property; ta: INTEGER;
 240         BEGIN
 241                 ASSERT(x # NIL, 20); ASSERT(x.next = NIL, 21); ASSERT(x # list, 22);
 242                 ASSERT(x.valid - x.known = {}, 23);
 243                 IF list # NIL THEN
 244                         ASSERT(list.valid - list.known = {}, 24);
 245                         ASSERT(Services.TypeLevel(list) = 1, 25)
 246                 END;
 247                 ta := SYSTEM.TYP(x^);
 248                 ASSERT(Services.TypeLevel(x) = 1, 26);
 249                 p := list; q := NIL;
 250                 WHILE (p # NIL) & (SYSTEM.TYP(p^) < ta) DO
 251                         q := p; p := p.next
 252                 END;
 253                 IF (p # NIL) & (SYSTEM.TYP(p^) = ta) THEN x.next := p.next ELSE x.next := p END;
 254                 IF q # NIL THEN q.next := x ELSE list := x END
 255         END Insert;
 256
 257         PROCEDURE CopyOfList* (p: Property): Property;
 258                 VAR q, r, s: Property; t: Kernel.Type;
 259         BEGIN
 260                 q := NIL; s := NIL;
 261                 WHILE p # NIL DO
 262                         ASSERT(Services.TypeLevel(p) = 1, 20);
 263                         t := Kernel.TypeOf(p); Kernel.NewObj(r, t); ASSERT(r # NIL, 23);
 264                         SYSTEM.MOVE(p, r, t.size);
 265                         r.next := NIL;
 266                         IF q # NIL THEN q.next := r ELSE s := r END;
 267                         q := r; p := p.next
 268                 END;
 269                 RETURN s
 270         END CopyOfList;
 271
 272         PROCEDURE CopyOf* (p: Property): Property;
 273                 VAR r: Property; t: Kernel.Type;
 274         BEGIN
 275                 IF p # NIL THEN
 276                         ASSERT(Services.TypeLevel(p) = 1, 20);
 277                         t := Kernel.TypeOf(p); Kernel.NewObj(r, t); ASSERT(r # NIL, 23);
 278                         SYSTEM.MOVE(p, r, t.size);
 279                         r.next := NIL;
 280                 END;
 281                 RETURN r
 282         END CopyOf;
 283
 284         PROCEDURE Merge* (VAR base, override: Property);
 285                 VAR p, q, r, s: Property; tp, tr: INTEGER;
 286         BEGIN
 287                 ASSERT((base # override) OR (base = NIL), 20);
 288                 p := base; q := NIL; r := override; override := NIL;
 289                 IF p # NIL THEN
 290                         tp := SYSTEM.TYP(p^);
 291                         ASSERT(Services.TypeLevel(p) = 1, 21)
 292                 END;
 293                 IF r # NIL THEN
 294                         tr := SYSTEM.TYP(r^);
 295                         ASSERT(Services.TypeLevel(r) = 1, 22)
 296                 END;
 297                 WHILE (p # NIL) & (r # NIL) DO
 298                         ASSERT(p # r, 23);
 299                         WHILE (p # NIL) & (tp < tr) DO
 300                                 q := p; p := p.next;
 301                                 IF p # NIL THEN tp := SYSTEM.TYP(p^) END
 302                         END;
 303                         IF p # NIL THEN
 304                                 IF tp = tr THEN
 305                                         s := p.next; p.next := NIL; p := s;
 306                                         IF p # NIL THEN tp := SYSTEM.TYP(p^) END
 307                                 ELSE
 308                                 END;
 309                                 s := r.next;
 310                                 IF q # NIL THEN q.next := r ELSE base := r END;
 311                                 q := r; r.next := p; r := s;
 312                                 IF r # NIL THEN tr := SYSTEM.TYP(r^) END
 313                         END
 314                 END;
 315                 IF r # NIL THEN
 316                         IF q # NIL THEN q.next := r ELSE base := r END
 317                 END
 318         END Merge;
 319
 320         PROCEDURE Intersect* (VAR list: Property; x: Property; OUT equal: BOOLEAN);
 321                 VAR l, p, q, r, s: Property; plen, rlen, ta: INTEGER; filtered: BOOLEAN;
 322         BEGIN
 323                 ASSERT((x # list) OR (list = NIL), 20);
 324                 IF list # NIL THEN ASSERT(Services.TypeLevel(list) = 1, 21) END;
 325                 IF x # NIL THEN ASSERT(Services.TypeLevel(x) = 1, 22) END;
 326                 p := list; s := NIL; list := NIL; l := NIL; plen := 0;
 327                 r := x; rlen := 0; filtered := FALSE;
 328                 WHILE (p # NIL) & (r # NIL) DO
 329                         q := p.next; p.next := NIL; INC(plen);
 330                         ta := SYSTEM.TYP(p^);
 331                         WHILE (r # NIL) & (SYSTEM.TYP(r^) < ta) DO
 332                                 r := r.next; INC(rlen)
 333                         END;
 334                         IF (r # NIL) & (SYSTEM.TYP(r^) = ta) THEN
 335                                 ASSERT(r # p, 23);
 336                                 IF l # NIL THEN s.next := p ELSE l := p END;
 337                                 s := p;
 338                                 p.known := p.known + r.known;
 339                                 p.IntersectWith(r, equal);
 340                                 filtered := filtered OR ~equal OR (p.valid # r.valid);
 341                                 r := r.next; INC(rlen)
 342                         END;
 343                         p := q
 344                 END;
 345                 list := l;
 346                 equal := (p = NIL) & (r = NIL) & (plen = rlen) & ~filtered
 347         END Intersect;
 348
 349
 350         (** support for IntersectWith methods **)
 351
 352         PROCEDURE IntersectSelections* (a, aMask, b, bMask: SET; OUT c, cMask: SET; OUT equal: BOOLEAN);
 353         BEGIN
 354                 cMask := aMask * bMask - (a / b);
 355                 c := a * cMask;
 356                 equal := (aMask = bMask) & (bMask = cMask)
 357         END IntersectSelections;
 358
 359
 360         (** standard preferences protocols **)
 361
 362         PROCEDURE PreferredSize* (v: Views.View; minW, maxW, minH, maxH,  defW, defH: INTEGER;
 363                                                                                                 VAR w, h: INTEGER);
 364                 VAR p: SizePref;
 365         BEGIN
 366                 ASSERT(Views.undefined < minW, 20); ASSERT(minW < maxW, 21);
 367                 ASSERT(Views.undefined < minH, 23); ASSERT(minH < maxH, 24);
 368                 ASSERT(Views.undefined <= defW, 26);
 369                 ASSERT(Views.undefined <= defH, 28);
 370                 IF (w < Views.undefined) OR (w > maxW) THEN w := defW END;
 371                 IF (h < Views.undefined) OR (h > maxH) THEN h := defH END;
 372                 p.w := w; p.h := h; p.fixedW := FALSE; p.fixedH := FALSE;
 373                 Views.HandlePropMsg(v, p); w := p.w; h := p.h;
 374                 IF w = Views.undefined THEN w := defW END;
 375                 IF h = Views.undefined THEN h := defH END;
 376                 IF w < minW THEN w := minW ELSIF w > maxW THEN w := maxW END;
 377                 IF h < minH THEN h := minH ELSIF h > maxH THEN h := maxH END
 378         END PreferredSize;
 379
 380
 381         (** common resizing constraints **)
 382
 383         PROCEDURE ProportionalConstraint* (scaleW, scaleH: INTEGER; fixedW, fixedH: BOOLEAN; VAR w, h: INTEGER);
 384         (** pre: w > Views.undefined, h > Views.undefined **)
 385         (** post: (E s: s * scaleW = w, s * scaleH = h), |w * h - w' * h'| min! **)
 386                 VAR area: REAL;
 387         BEGIN
 388                 ASSERT(scaleW > Views.undefined, 22); ASSERT(scaleH > Views.undefined, 23);
 389                 IF fixedH THEN
 390                         ASSERT(~fixedW, 24);
 391                         ASSERT(h > Views.undefined, 21);
 392                         area := h; area := area * scaleW;
 393                         w := SHORT(ENTIER(area / scaleH))
 394                 ELSIF fixedW THEN
 395                         ASSERT(w > Views.undefined, 20);
 396                         area := w; area := area * scaleH;
 397                         h := SHORT(ENTIER(area / scaleW))
 398                 ELSE
 399                         ASSERT(w > Views.undefined, 20); ASSERT(h > Views.undefined, 21);
 400                         area := w; area := area * h;
 401                         w := SHORT(ENTIER(Math.(*L*)Sqrt(area * scaleW / scaleH)));
 402                         h := SHORT(ENTIER(Math.(*L*)Sqrt(area * scaleH / scaleW)))
 403                 END
 404         END ProportionalConstraint;
 405
 406         PROCEDURE GridConstraint* (gridX, gridY: INTEGER; VAR x, y: INTEGER);
 407                 VAR dx, dy: INTEGER;
 408         BEGIN
 409                 ASSERT(gridX > Views.undefined, 20);
 410                 ASSERT(gridY > Views.undefined, 21);
 411                 dx := x MOD gridX;
 412                 IF dx < gridX DIV 2 THEN DEC(x, dx) ELSE INC(x, (-x) MOD gridX) END;
 413                 dy := y MOD gridY;
 414                 IF dy < gridY DIV 2 THEN DEC(y, dy) ELSE INC(y, (-y) MOD gridY) END
 415         END GridConstraint;
 416
 417         PROCEDURE ThisType* (view: Views.View; type: Stores.TypeName): Views.View;
 418                 VAR msg: TypePref;
 419         BEGIN
 420                 msg.type := type; msg.view := NIL;
 421                 Views.HandlePropMsg(view, msg);
 422                 RETURN msg.view
 423         END ThisType;
 424
 425 END Properties.