Syntax10.Scn.Fnt:InfoElemsAllocXSyntax10.Scn.FntStampElemsAlloc2002-Aug-13n"Title": Pictures for X11 "Author": RLI, with help of MAH "Abstract": Implements Pictures-Module as described in Pictures.Text "Keywords": Pictures, Graphics, BMP "Version": 0.01prealpha "From": 18 Dec 96 "Until":  "Changes": 18 Dec 96 MAH, RLI CleanUp from MacVersion, crucial parts left open 21 May 97 RLI Finished alpha version, clipping taken from Display - Module 19 Aug 97 RLI Pseudo color visual support, Get/SetScanline extensions 08 Oct 97 RLI InsertText included, Bug in Match fixed 08 Oct 97 RLI Bugs in GetPixelRGB fixed "Hints": Edit.Open Pictures.Text Parts of this module taken from Windows.bBalloonElemsAllocSyntax10.Scn.Fnt`Syntax10b.Scn.Fnt  Syntax10i.Scn.Fnt!& q  "BitmapInfoHeader" BitmapInfoHeader = RECORD size, width, height: LONGINT; planes, bits: INTEGER; compression, sizeImage, xPelsPerMeter, yPelsPerMeter, clrUsed, clrImportant: LONGINT END; BitmapInfoHeader contains basic information about a .bmp - Picture: size contains the size of the BitmapInfoHeader in Byte width, height refer to the size of the Picture planes must be 1 bits represents the depth of the picture, i.e. 1, 4, 8, 24 or 32 compression must be 0 in order to work with Pictures sizeImage is only relevant for compressed Pictures xPelsPerMeter and yPelsPerMeter define the resolution of the Picture in Pixels per Meter clrUsed contains the number of used colors or 0 clrImportant contains the number of important colors "Picture" The central Type of Pictures. See PictureDesc and Pictures.Text for detailed description. "PictureDesc" PictureDesc* = RECORD width-, height-, depth-: INTEGER; (* width and height of Bitmap *) pictData: POINTER TO ARRAY OF CHAR; (* raw image data *) bpl: LONGINT; (* bytes per line in raw data *) rgb: RGB; col: SHORTINT; registered: BOOLEAN; infoHead: BitmapInfoHeader; pixels: ARRAY 256 OF LONGINT; (* Handle to X11 - Color cell *) cols: ARRAY 256 OF RECORD red, green, blue: INTEGER END END; pixels and cols are redundant for efficiency reasons "Gc" The X11-Graphics context needed for almost every operation under X. Since there is no possibility to access the gc of Module Display, Pictures has it's own gc. Note that the gc is allocated but never freed with XFree(...). Since this behaviour is the same in all modules (e.g. Display) I guess it does not matter much. "CreateGC" See Gc for details "Window" Window is needed for clipping only. Clipping is taken from Display. "Secondary" This procedure was taken from Display. "InitPictures" Initializes the global TrueColor palette. Unfortunately this process takes a while. This part should be optimized. "Print" You need a special Oberon.Header.ps to print Pictures.cSyntax10b.Scn.Fnt .  Syntax10i.Scn.Fnt  v O   ;      /8FoldElemsNew8 ,88 08e8 8}k8 85~8 8U8 8K8A8E8"8e8888 8 8eP_^M3O8 8Z8)8-y8&8}8 (8a8 $8 88- 8 58G88$Syntax10i.Scn.Fnt22how to copy without messing up overlapping regions7'KeplerElemsAllocKeplerGraphsGraphDescKeplerGraphsStarDesc~}~~~}~}}|~~ } ~ }  ~~ |{z{z{{y{z{z||yKepler1TextureDescKepler1RectangleDescKepler1AttrDesc KeplerFramesCaptionDesc(x0, y0)Syntax10.Scn.Fnt (x1, y1)Syntax10.Scn.Fnt y0 < y1Syntax10.Scn.Fnt  y0 > y1Syntax10.Scn.Fnty0 = y1, x0 < x1Syntax10.Scn.Fnt !"#$y0 = y1, x0 > x1Syntax10.Scn.Fnt%E8 # "!8@88 MarkElemsAlloc 8 THEN (* x := X11.AllocColor(X11.display, X11.cmap, S.ADR(xc)); ASSERT(x # 0, 100); gh *) p.pixels[col] := xc.pixel ELSE y := (blue DIV 64) * 25 + (green DIV 52) * 5 + red DIV 52; p.pixels[col] := X11.pixelValues[y + 16] END; p.cols[col].red := red; p.cols[col].green := green; p.cols[col].blue := blue END SetPalette;  PROCEDURE (p: Picture) GetPalette* (col: INTEGER; VAR red, green, blue: INTEGER);  BEGIN red := p.cols[col].red; green := p.cols[col].green; blue := p.cols[col].blue END GetPalette;  PROCEDURE (p: Picture) SetColorRGB* (r, g, b: INTEGER);  VAR i, cnt, idx: INTEGER; m, match: LONGINT; PROCEDURE Match (idx: INTEGER) : LONGINT; VAR red, green, blue: INTEGER; r2, g2, b2: LONGINT; BEGIN p.GetPalette (idx, red, green, blue); r2 := red-r; g2 := green-g; b2 := blue-b; RETURN r2*r2 + g2*g2 + b2*b2; END Match; PROCEDURE checkCache(r, g, b: INTEGER; VAR idx: INTEGER): BOOLEAN; VAR i: INTEGER; BEGIN i := 0; WHILE (i < cacheSize) & ((r # pCache[i].r) OR (g # pCache[i].g) OR (b # pCache[i].b)) DO INC(i); END; idx := pCache[i].idx; RETURN i < cacheSize; END checkCache; BEGIN IF useCache & checkCache(r, g, b, idx) THEN p.col := SHORT(idx); (* INC(cacheHits); *) RETURN END; (* INC(cacheMisses); *) p.rgb.red := r; p.rgb.green := g; p.rgb.blue := b; IF p.depth <= 8 THEN (* find matching color index *) cnt := SHORT (ASH (1, p.depth)); idx := 0; match := Match (0); FOR i := 1 TO cnt - 1 DO m := Match(i); IF m < match THEN match := m; idx := i END END; p.col := SHORT (idx); FOR i := 0 TO cacheSize-2 DO pCache[i] := pCache[i+1]; END; pCache[cacheSize-1].r := r; pCache[cacheSize-1].g := g; pCache[cacheSize-1].b := b; pCache[cacheSize-1].idx := idx; END END SetColorRGB;  PROCEDURE (p: Picture) SetColorIdx* (col: INTEGER);  VAR r, g, b: INTEGER; BEGIN (* IF (X11.depth <= 8) THEN ASSERT(col <= 27) END; *) p.col := SHORT(col); Display.GetColor(col, r, g, b); p.rgb.red := r; p.rgb.green := g; p.rgb.blue := b END SetColorIdx;  PROCEDURE (p: Picture) GetColorIdx* (VAR col: INTEGER);  BEGIN IF p.depth <= 8 THEN col := p.col ELSE col := - 1 END END GetColorIdx;  PROCEDURE (p: Picture) GetColorRGB* (VAR r, g, b: INTEGER);  BEGIN r := p.rgb.red; g := p.rgb.green; b := p.rgb.blue END GetColorRGB;  PROCEDURE InitPic (p: Picture; width, height, depth: INTEGER);  VAR filler: INTEGER; h, w: LONGINT; BEGIN p.depth := depth; p.width := width; p.height := height; h := height; w := width; filler := SHORT (ENTIER (w * p.depth / 8)); IF w * p.depth / 8 # filler THEN INC (filler) END; filler := (4 - filler MOD 4) MOD 4; IF p.depth <= 8 THEN p.bpl := SHORT(((w * p.depth + 7) DIV 8) + filler); ELSE p.bpl := SHORT(w * 3 + filler) END; ASSERT(p.bpl >= 0); p.pictData := Kernel.malloc(h * p.bpl); ASSERT(p.pictData # 0); (* IF ~p.registered THEN Kernel.RegisterObject (p, Finalizer); p.registered := TRUE END gh *) END InitPic;  PROCEDURE (p: Picture) Init* (width, height, depth: INTEGER);  VAR r, g, b: INTEGER; BEGIN InitPic (p, width, height, depth); IF p.depth = 0 THEN RETURN END; IF p.depth = 8 THEN (* set standard palette *) FOR r := 0 TO 5 DO FOR g := 0 TO 5 DO FOR b := 0 TO 6 DO p.SetPalette(b+g*7+r*42, r*43, g*43, b*37) END; END; END; END; p.infoHead.size := 40; p.infoHead.width := width; p.infoHead.height := height; p.infoHead.planes := 1; p.infoHead.bits := depth; p.infoHead.compression := 0; p.infoHead.sizeImage := 0; p.infoHead.xPelsPerMeter := 0; p.infoHead.yPelsPerMeter := 0; p.infoHead.clrUsed := 0; p.infoHead.clrImportant := 0 END Init;  PROCEDURE (p: Picture) Copy* (VAR res: INTEGER);  BEGIN res := error END Copy;  PROCEDURE (p: Picture) Paste* (VAR res: INTEGER);  BEGIN res := error END Paste;  PROCEDURE (p: Picture) SetPixel* (x, y, mode: INTEGER);  VAR base, adr: LONGINT; ch: CHAR; set: SET; col, pcol: INTEGER; r, g, b: INTEGER; black: BOOLEAN; (* TRUE iff actually black, i.e. # Display.black, set pixel if paint in black *) BEGIN IF (x >= 0) & (x < p.width) & (y >= 0) & (y < p.height) THEN base := p.pictData + p.bpl * y; CASE p.depth OF 1: adr := base + x DIV 8; x := 7 - x MOD 8; black := p.col # Display.black; (* a bit that is set selects the color with idx 15 in the system palette (i.e., really black), a bit that is not set selects the color with idx 0 in the system palette (i.e., really white) *) S.GET(adr, ch); set := S.VAL(SET, ch) * {0..7}; CASE mode OF Display.replace: IF black THEN INCL(set, x) ELSE EXCL(set, x) END ; S.PUT(adr, S.VAL(CHAR, set)) | Display.paint: IF black THEN INCL(set, x); S.PUT(adr, S.VAL(CHAR, set)) END | Display.invert: IF black THEN set := set / {x}; S.PUT(adr, S.VAL(CHAR, set)) END END | 4: adr := base + x DIV 2; S.GET(adr, ch); IF (mode = Display.replace) OR (mode = Display.paint) & (p.col # Display.black) THEN IF ODD(x) THEN ch := S.VAL(CHAR, S.VAL(SET, ch) * {4..7} + S.VAL(SET, p.col) * {0..3}) ELSE (* Compiler bug (?) workaround, RLI, 14 May 1997 *) pcol := p.col; ch := S.VAL(CHAR, S.VAL(SET, ch) * {0..3} + S.VAL(SET, S.LSH(pcol, 4)) * {4..7}) END ; S.PUT(adr, ch) ELSIF mode = Display.invert THEN IF p.col # Display.black THEN IF ODD(x) THEN col := 15 - S.VAL(INTEGER, S.VAL(SET, ch) * {0..3}); S.PUT(adr, S.VAL(CHAR, S.VAL(SET, ch) * {4..7} + S.VAL(SET, col) * {0..3})) ELSE col := S.VAL(INTEGER, S.VAL(SET, ch) * {4..7}); col := 15 - S.LSH(col, - 4); S.PUT(adr, S.VAL(CHAR, S.VAL(SET, ch) * {0..3} + S.VAL(SET, S.LSH(col, 4)) * {4..7})) END END END | 8: adr := base + x; IF (mode = Display.replace) OR (mode = Display.paint) & (p.col # Display.black) THEN S.PUT(adr, CHR(p.col)) ELSIF mode = Display.invert THEN S.GET(adr, ch); col := ORD(ch); IF col <= 15 THEN S.PUT(adr, CHR(15 - col)) ELSE S.PUT(adr, CHR(255 - col)) END END | 16: adr := base + x * 2; IF mode IN {Display.replace, Display.paint} THEN r := S.LSH(p.rgb.red, - 3); g := S.LSH(p.rgb.green, - 3); b := S.LSH(p.rgb.blue, - 3); S.PUT(adr, S.VAL(INTEGER, b + ASH(g, 5) + ASH(r, 10))) ELSIF mode = Display.invert THEN S.GET(adr, col); r := 255 - col DIV 1024 MOD 32; g := 255 - col DIV 32 MOD 32; b := 255 - col MOD 32; S.PUT(adr, S.VAL(INTEGER, b + ASH(g, 5) + ASH(r, 10))) END | 24: adr := base + x * 3; IF mode IN {Display.replace, Display.paint} THEN S.PUT(adr, p.rgb.blue); INC(adr); S.PUT(adr, p.rgb.green); INC(adr); S.PUT(adr, p.rgb.red) ELSIF mode = Display.invert THEN S.GET(adr, ch); S.PUT(adr, CHR(255 - ORD(ch))); INC(adr); S.GET(adr, ch); S.PUT(adr, CHR(255 - ORD(ch))); INC(adr); S.GET(adr, ch); S.PUT(adr, CHR(255 - ORD(ch))) END | 32: adr := base + x * 4; IF mode IN {Display.replace, Display.paint} THEN S.PUT(adr, p.rgb.blue); INC(adr); S.PUT(adr, p.rgb.green); INC(adr); S.PUT(adr, p.rgb.red) ELSIF mode = Display.invert THEN S.GET(adr, ch); S.PUT(adr, CHR(255 - ORD(ch))); INC(adr); S.GET(adr, ch); S.PUT(adr, CHR(255 - ORD(ch))); INC(adr); S.GET(adr, ch); S.PUT(adr, CHR(255 - ORD(ch))) END END END END SetPixel;  PROCEDURE (p: Picture) ReplConst* (x, y, w, h, mode: INTEGER);  (* mode la Display, fllt (x,y) w,h mit Farbe p.col oder p.rgb je nach Art des Bildes *) VAR i, j: INTEGER; pixVal, dummy: LONGINT; BEGIN FOR i := x TO x + w DO FOR j := y TO y + h DO p.SetPixel(i, j, mode) END END END ReplConst;  PROCEDURE (p: Picture) Load* (VAR r: Files.Rider; VAR res: INTEGER);  VAR i, dummy, cnt, bits: INTEGER; id1, id2: CHAR; y, width, height, offset, startPos, filelen: LONGINT; rgb: FileRGB; buffer: POINTER TO ARRAY OF CHAR; BEGIN startPos := Files.Pos (r); Files.Read (r, id1); Files.Read (r, id2); IF (id1 # 'B') OR (id2 # 'M') THEN res := error; RETURN END; Files.ReadLInt (r, filelen); Files.ReadInt (r, dummy); ASSERT (dummy = 0); Files.ReadInt (r, dummy); ASSERT(dummy = 0); Files.ReadLInt (r, offset); (* offset of data *) Files.ReadLInt (r, p.infoHead.size); Files.ReadLInt (r, p.infoHead.width); Files.ReadLInt (r, p.infoHead.height); Files.ReadInt (r, p.infoHead.planes); Files.ReadInt (r, p.infoHead.bits); Files.ReadLInt (r, p.infoHead.compression); Files.ReadLInt (r, p.infoHead.sizeImage); Files.ReadLInt (r, p.infoHead.xPelsPerMeter); Files.ReadLInt (r, p.infoHead.yPelsPerMeter); Files.ReadLInt (r, p.infoHead.clrUsed); Files.ReadLInt (r, p.infoHead.clrImportant); IF p.infoHead.compression > 0 THEN HALT (99) END; width := p.infoHead.width; height := p.infoHead.height; bits := p.infoHead.bits; InitPic (p, SHORT (width), SHORT (height), p.infoHead.bits); IF p.depth = 0 THEN res := error; RETURN END; IF bits <= 8 THEN cnt := SHORT (ASH (1, bits)); FOR i := 0 TO cnt - 1 DO Files.ReadBytes (r, rgb, 4); p.SetPalette(i, ORD(rgb.b), ORD(rgb.g), ORD(rgb.r)) END END; Files.Set (r, Files.Base (r), offset + startPos); ASSERT(p.pictData # 0); NEW(buffer, p.bpl); FOR y := 0 TO height - 1 DO Files.ReadBytes(r, buffer^, p.bpl); S.MOVE(S.ADR(buffer^), p.pictData + y * p.bpl, p.bpl) END; p.height := SHORT(height); p.width := SHORT(width); res := done END Load;  PROCEDURE (p: Picture) Update* (new: Picture; x, y, w, h: INTEGER);  VAR m: UpdateMsg; BEGIN m.p := p; m.new := new; m.x := x; m.y := y; m.w := w; m.h := h; Viewers.Broadcast (m) END Update;  PROCEDURE (p: Picture) GetPixelRGB* (x, y: INTEGER; VAR r, g, b: INTEGER);  VAR pix: LONGINT; i: INTEGER; red, green, blue, idx: CHAR; BEGIN IF (x >= 0) & (x < p.width) & (y >= 0) & (y < p.height) THEN IF p.depth > 8 THEN S.GET(p.pictData + y * p.bpl + x * 3, blue); S.GET(p.pictData + y * p.bpl + x * 3 + 1, green); S.GET(p.pictData + y * p.bpl + x * 3 + 2, red); r := ORD(red); g := ORD(green); b := ORD(blue) ELSIF p.depth = 8 THEN S.GET(p.pictData + y * p.bpl + x, idx); i := ORD(idx); p.GetPalette(i, r, g, b) ELSIF p.depth = 4 THEN S.GET(p.pictData + y * p.bpl + x DIV 2, idx); i := ORD(idx); IF ODD(x) THEN i := i MOD 16 ELSE i := i DIV 16 END; p.GetPalette(i, r, g, b) ELSIF p.depth = 1 THEN S.GET(p.pictData + y * p.bpl + x DIV 8, idx); i := ORD(idx); IF S.BIT(S.ADR(i), 7 - (x MOD 8)) THEN p.GetPalette(1, r, g, b) ELSE p.GetPalette(0, r, g, b) END END END; END GetPixelRGB;  PROCEDURE (p: Picture) GetPixelIdx* (x, y: INTEGER; VAR col: INTEGER);  VAR c: CHAR; BEGIN ASSERT (p.depth <= 8); IF (x >= 0) & (x < p.width) & (y >= 0) & (y < p.height) THEN IF p.depth = 8 THEN S.GET(p.pictData + y * p.bpl + x, c); col := ORD(c) ELSIF p.depth = 4 THEN S.GET(p.pictData + y * p.bpl + x DIV 2, c); col := ORD(c); IF ODD(x) THEN col := col DIV 16 ELSE col := col MOD 16 END ELSIF p.depth = 1 THEN S.GET(p.pictData + y * p.bpl + x DIV 8, c); col := ORD(c); IF S.BIT(S.ADR(col), x MOD 8) THEN col := 1 ELSE col := 0 END END END END GetPixelIdx;  PROCEDURE (p: Picture) Store* (VAR r: Files.Rider);  VAR filelen, offset: LONGINT; rgb: FileRGB; blue, green, red, cnt, i, filler, y, x, depth: INTEGER; dstRowStart, rowBytes, f, m, pixVal: LONGINT; bbb: ARRAY 4*1024 OF CHAR; buffer: POINTER TO ARRAY OF CHAR; BEGIN Files.Write(r, 'B'); Files.Write(r, 'M'); IF p.depth < 24 THEN offset := ASH(1, p.depth) * 4 ELSE offset := 0 END ; INC(offset, SIZE(BitmapInfoHeader)); INC(offset, 2 + 4 + 2 + 2 + 4); (* BITMAPFILEHEADER *) IF p.depth = 32 THEN depth := 24 ELSE depth := p.depth END; filelen := offset + p.height * (((p.width * depth + 7) DIV 8 + 4 - 1) DIV 4 * 4); (* filelen := offset + p.width * p.height; *) Files.WriteLInt(r, filelen); (* file length *) Files.WriteInt(r, 0); Files.WriteInt(r, 0); Files.WriteLInt(r, offset); Files.WriteLInt (r, p.infoHead.size); Files.WriteLInt (r, p.infoHead.width); Files.WriteLInt (r, p.infoHead.height); Files.WriteInt (r, p.infoHead.planes); Files.WriteInt (r, p.infoHead.bits); Files.WriteLInt (r, p.infoHead.compression); Files.WriteLInt (r, p.infoHead.sizeImage); Files.WriteLInt (r, p.infoHead.xPelsPerMeter); Files.WriteLInt (r, p.infoHead.yPelsPerMeter); Files.WriteLInt (r, p.infoHead.clrUsed); Files.WriteLInt (r, p.infoHead.clrImportant); IF p.depth <= 8 THEN cnt := SHORT (ASH (1, p.depth)); FOR i := 0 TO cnt - 1 DO p.GetPalette(i, blue, green, red); rgb.b := CHR(blue); rgb.g := CHR(green); rgb.r := CHR(red); Files.WriteBytes (r, rgb, 4) END END; NEW(buffer, p.bpl); FOR y := 0 TO p.height - 1 DO S.MOVE(p.pictData + y * p.bpl, S.ADR(buffer^), p.bpl); Files.WriteBytes(r, buffer^, p.bpl) END END Store;  PROCEDURE (p: Picture) CopyBlock* (dP: Picture; sx, sy, w, h, dx, dy, mode: INTEGER);  VAR lastx, lasty: INTEGER; (* will not be copied, area to be copied is [sx..lastX[, [sy, lasty[ *) r, g, b, x0, y0, x, y: INTEGER; start, end: LONGINT;  BEGIN useCache := TRUE; FOR x := 0 TO cacheSize-1 DO pCache[x].r := -1 END; IF (sx >= 0) & (sx < p.width) & (sy >= 0) & (sy < p.height) & (dx >= 0) & (dx < dP.width) & (dy >= 0) & (dy < dP.height) THEN IF p.width < sx + w THEN lastx := p.width ELSE lastx := sx + w END ; IF dP.width < lastx THEN lastx := dP.width END ; IF p.height < sy + h THEN lasty := p.height ELSE lasty := sy + h END ; IF dP.height < lasty THEN lasty := dP.height END ; IF sy < dy THEN (* copy top most pixels first *) y := dy; FOR y0 := lasty - 1 TO sy BY - 1 DO x := dx; FOR x0 := sx TO lastx - 1 DO p.GetPixelRGB(x0, y0, r, g, b); dP.SetColorRGB(r, g, b); dP.SetPixel(x, y, mode); INC(x) END ; DEC(y) END ELSIF sy > dy THEN (* copy bottom most pixels first *) y := dy + lasty - 1 - sy; FOR y0 := sy TO lasty - 1 DO x := dx; FOR x0 := sx TO lastx - 1 DO p.GetPixelRGB(x0, y0, r, g, b); dP.SetColorRGB(r, g, b); dP.SetPixel(x, y, mode); INC(x) END ; INC(y) END ELSIF (* sy = dy *) sx < dx THEN (* copy right most pixels first *) x := dx + lastx - 1 - sx; FOR x0 := lastx - 1 TO sx BY - 1 DO y := dy; FOR y0 := sy TO lasty - 1 DO p.GetPixelRGB(x0, y0, r, g, b); dP.SetColorRGB(r, g, b); dP.SetPixel(x, y, mode); INC(y) END ; DEC(x) END ELSE (* (sy = dy) & (sx >= dx) *) (* copy left most pixels first *) x := dx; FOR x0 := sx TO lastx - 1 DO y := dy; FOR y0 := sy TO lasty - 1 DO p.GetPixelRGB(x0, y0, r, g, b); dP.SetColorRGB(r, g, b); dP.SetPixel(x, y, mode); INC(y) END ; INC(x) END END END; useCache := FALSE; END CopyBlock;  PROCEDURE (p: Picture) GetPixelValue (idx: LONGINT): LONGINT;  VAR res: LONGINT; r, g, b: CHAR; y: INTEGER; BEGIN S.GET(p.pictData + idx, b); S.GET(p.pictData + idx + 1, g); S.GET(p.pictData + idx + 2, r); IF X11.depth >= 24 THEN res := ORD(b) + ASH(ORD(g), 8) + ASH(ORD(r), 16) ELSIF X11.depth > 8 THEN (* This is rather heuristic *) res := ASH(ORD(r), - 3) + ASH(ASH(ORD(g), - 2), 5) + ASH(ASH(ORD(b), - 3), 11) ELSE y := (ORD(r) DIV 64) * 25 + (ORD(g) DIV 52) * 5 + ORD(b) DIV 52; res := X11.pixelValues[y + 16] END; RETURN res END GetPixelValue;  PROCEDURE Dithering;  VAR i, j, idx, ip3: INTEGER; ln: ARRAY 1280 * 3 OF INTEGER; r, g, b, col: INTEGER; pix, K, K1, K2, error, err7, err3, err5, w, w3: INTEGER; p: Picture; dt: DitherTask; BEGIN (* Floyd/Steinberg error diffusion dithering, cf. Foley, van Damm: Computer Graphics page 573 *) dt := Oberon.CurTask(DitherTask); p := dt.p; w := p.width; w3 := w * 3; j := dt.cury; WHILE (j < (dt.cury + 20)) & (j < p.height) DO FOR i := 0 TO w - 1 DO IF p.depth <= 8 THEN p.GetPixelIdx(i, j, col); b := dt.oldColors[col].red; g := dt.oldColors[col].green; r := dt.oldColors[col].blue ELSE p.GetPixelRGB(i, j, b, g, r) END ; idx := i * 3; ln[idx] := r + dt.err[idx]; INC(idx); ln[idx] := g + dt.err[idx]; INC(idx); ln[idx] := b + dt.err[idx]; dt.err[idx - 2] := 0; dt.err[idx - 1] := 0; dt.err[idx] := 0 END ; pix := 3; ln[w3] := 0; ln[w3 + 1] := 0; ln[w3 + 2] := 0; FOR i := 0 TO w3 - 1 DO K2 := K1; K1 := K; ip3 := i + 3; IF pix = 3 THEN K := ln[i] DIV 64; IF K > 3 THEN K := 3 ELSIF K < 0 THEN K := 0 END ; error := ln[i] - (K * 64); IF ABS(ln[i] - ln[ip3]) > 64 THEN error := 0 END (* avoid strange effects on dark/light borders *) ELSE K := ln[i] DIV 51; IF K > 4 THEN K := 4 ELSIF K < 0 THEN K := 0 END ; error := ln[i] - (K * 51); IF ABS(ln[i] - ln[ip3]) > 51 THEN error := 0 END (* avoid strange effects on dark/light borders *) END; err7 := error * 7 DIV 16; err3 := error * 3 DIV 16; err5 := error * 5 DIV 16; INC(ln[ip3], err7); IF i > 2 THEN INC(dt.err[i - 3], err3) END ; INC(dt.err[i], err5); INC(dt.err[ip3], error - err7 - err3 - err5); DEC(pix); IF pix = 0 THEN p.SetColorIdx(K2 * 25 + K1 * 5 + K + 16); p.SetPixel(i DIV 3, j, Display.replace); pix := 3 END END ; INC(j) END ; IF ((Oberon.Time() - dt.lastUpdateTime) > 0.5 * Input.TimeUnit) OR (j >= p.height) THEN (* at least half a second between updates, don't forget the last update *) dt.lastUpdateTime := Oberon.Time(); p.Update(NIL, 0, dt.lastUpdateY, p.width, j - dt.lastUpdateY); dt.lastUpdateY := j END ; dt.cury := j; IF j >= p.height THEN Oberon.Remove(dt) END END Dithering;  PROCEDURE DitheringBW;  VAR i, j, idx, ip3: INTEGER; ln: ARRAY 1280 * 3 OF INTEGER; r, g, b, col: INTEGER; pix, K, K1, K2, error, err7, err3, err5, w, w3: INTEGER; p: Picture; dt: DitherTask; BEGIN (* Floyd/Steinberg error diffusion dithering, cf. Foley, van Damm: Computer Graphics page 573 *) dt := Oberon.CurTask(DitherTask); p := dt.p; w := p.width; w3 := w * 3; j := dt.cury; WHILE (j < (dt.cury + 20)) & (j < p.height) DO FOR i := 0 TO w - 1 DO IF p.depth <= 8 THEN p.GetPixelIdx(i, j, col); b := dt.oldColors[col].red; g := dt.oldColors[col].green; r := dt.oldColors[col].blue ELSE p.GetPixelRGB(i, j, b, g, r) END ; idx := i * 3; ln[idx] := r + dt.err[idx]; INC(idx); ln[idx] := g + dt.err[idx]; INC(idx); ln[idx] := b + dt.err[idx]; dt.err[idx - 2] := 0; dt.err[idx - 1] := 0; dt.err[idx] := 0 END ; pix := 3; ln[w3] := 0; ln[w3 + 1] := 0; ln[w3 + 2] := 0; FOR i := 0 TO w3 - 1 DO K2 := K1; K1 := K; ip3 := i + 3; K := ln[i] DIV 128; IF K > 1 THEN K := 1 ELSIF K < 0 THEN K := 0 END ; error := ln[i] - (K * 64); IF ABS(ln[i] - ln[ip3]) > 128 THEN error := 0 END; (* avoid strange effects on dark/light borders *) err7 := error * 7 DIV 16; err3 := error * 3 DIV 16; err5 := error * 5 DIV 16; INC(ln[ip3], err7); IF i > 2 THEN INC(dt.err[i - 3], err3) END ; INC(dt.err[i], err5); INC(dt.err[ip3], error - err7 - err3 - err5); DEC(pix); IF pix = 0 THEN IF K + K1 + K2 > 2 THEN p.SetColorIdx(Display.black) ELSE p.SetColorIdx(Display.white) END; p.SetPixel(i DIV 3, j, Display.replace); pix := 3 END END ; INC(j) END ; IF ((Oberon.Time() - dt.lastUpdateTime) > 0.5 * Input.TimeUnit) OR (j >= p.height) THEN (* at least half a second between updates, don't forget the last update *) dt.lastUpdateTime := Oberon.Time(); p.Update(NIL, 0, dt.lastUpdateY, p.width, j - dt.lastUpdateY); dt.lastUpdateY := j END ; dt.cury := j; IF j >= p.height THEN Oberon.Remove(dt) END END DitheringBW;  PROCEDURE Dither (p: Picture);  VAR ditherTask: DitherTask; i, red, green, blue, r, g, b: INTEGER; necessary: BOOLEAN; BEGIN NEW(ditherTask); ditherTask.safe := FALSE; IF X11.colorClass = X11.monochrome THEN ditherTask.handle := DitheringBW ELSE ditherTask.handle := Dithering END; ditherTask.p := p; necessary := X11.depth <= 8; IF p.depth <= 8 THEN FOR i := 0 TO 255 DO Display.GetColor(i, r, g, b); red := p.cols[i].red; green := p.cols[i].green; blue := p.cols[i].blue; necessary := necessary OR (r # red) OR (g # green) OR (b # blue); ditherTask.oldColors[i] := p.cols[i]; p.SetPalette(i, r, g, b) END END ; IF necessary THEN FOR i := 0 TO LEN(ditherTask.err) - 1 DO ditherTask.err[i] := 0 END ; ditherTask.cury := 0; ditherTask.lastUpdateY := 0; ditherTask.lastUpdateTime := Oberon.Time(); Oberon.Install(ditherTask) END END Dither;  PROCEDURE (p: Picture) Draw* (dx, dy, mode: INTEGER);  VAR iPtr: X11.ImagePtr; img: X11.Image; filler, bits: INTEGER; x, y, z, n, dummy2: LONGINT; c: CHAR; BEGIN IF (p.pictData = 0) THEN RETURN END; bits := p.infoHead.bits; img := X11.CreateImage(X11.display, X11.visualptr, X11.depth, X11.ZPixmap, 0, 0, p.width, p.height, 8, 0); ASSERT(img # 0); iPtr := S.VAL(X11.ImagePtr, img); ASSERT(iPtr # NIL); iPtr.data := Kernel.malloc(iPtr.bytesPerLine * p.height); ASSERT(iPtr.data # 0); (* filler: Anz alignment Bytes im .BMP-Datei *) filler := SHORT (ENTIER (p.width * bits / 8)); IF p.width * bits / 8 # filler THEN INC (filler) END; filler := (4 - filler MOD 4) MOD 4; IF p.depth > 8 THEN z := 0; FOR y := 0 TO p.height - 1 DO FOR x := 0 TO p.width - 1 DO dummy2 := X11.PutPixel(img, x, p.height - y - 1, p.GetPixelValue(z)); INC(z, 3) END; z := z + filler END ELSIF p.depth = 8 THEN FOR y := 0 TO p.height - 1 DO FOR x := 0 TO p.width - 1 DO S.GET(p.pictData + y * p.bpl + x, c); dummy2 := X11.PutPixel(img, x, p.height - y - 1, p.pixels[ORD(c)]) END END ELSIF p.depth = 4 THEN FOR y := 0 TO p.height - 1 DO FOR x := 0 TO p.bpl - 1 DO S.GET(p.pictData + y * p.bpl + x, c); z := ORD(c); IF x * 2 < p.width THEN dummy2 := X11.PutPixel(img, x * 2 + 1, p.height - y - 1, p.pixels[z DIV 16]) END; IF (x * 2 + 1) < p.width THEN dummy2 := X11.PutPixel(img, x * 2, p.height - y - 1, p.pixels[z MOD 16]) END END END ELSIF p.depth = 1 THEN FOR y := 0 TO p.height - 1 DO FOR x := 0 TO p.bpl - 1 DO FOR n := 0 TO 7 DO IF x * 8 + n < p.width THEN IF S.BIT(p.pictData + y * p.bpl + x, 7 - n) THEN dummy2 := X11.PutPixel(img, x * 8 + n, p.height - y - 1, p.pixels[1]) ELSE dummy2 := X11.PutPixel(img, x * 8 + n, p.height - y - 1, p.pixels[0]) END END END END END END; IF (p.width = 0) OR (p.height = 0) THEN RETURN END; X11.SetFunction(X11.display, Gc, X11.function[mode]); X11.PutImage(X11.display, X11.primary, Gc, img, 0, 0, dx, Display.Height - dy - p.height, p.width, p.height); Kernel.free(iPtr.data); X11.Free(img) END Draw;  PROCEDURE (p: Picture) DrawStretched* (sx, sy, sw, sh, dx, dy, dw, dh, mode: INTEGER);  VAR p2: Picture; x, y: LONGINT; col, r, g, b: INTEGER; BEGIN NEW(p2); p2.Init(dw, dh, p.depth); p2.pixels := p.pixels; p2.cols := p.cols; FOR y := 0 TO dh - 1 DO FOR x := 0 TO dw - 1 DO IF p.depth <= 8 THEN p.GetPixelIdx(SHORT(sx + x * sw DIV dw), SHORT(sy + y * sh DIV dh), col); p2.SetColorIdx(col); p2.SetPixel(SHORT(x), SHORT(y), Display.replace) ELSE p.GetPixelRGB(SHORT(sx + x * sw DIV dw), SHORT(sy + y * sh DIV dh), r, g, b); p2.SetColorRGB(r, g, b); p2.SetPixel(SHORT(x), SHORT(y), Display.replace) END END END; p2.Draw(dx, dy, mode) END DrawStretched;  PROCEDURE Secondary (F: Display.Frame): BOOLEAN;  VAR cliprect: X11.Rectangle; BEGIN IF X11.lclen > 0 THEN X11.FlushLCache END ; cliprect.x := F.X; cliprect.y := X11.Height - F.Y - F.H; cliprect.w := F.W; cliprect.h := F.H; IF F.Y >= 0 THEN Window := X11.primary ELSE Window := X11.secondary; INC(cliprect.y, X11.UBottom) END ; IF (cliprect.x <= 0) & (cliprect.y <= 0) & (cliprect.w >= X11.Width) & (cliprect.h >= X11.Height) THEN (* no clipping *) X11.SetClipMask(X11.display, Gc, X11.None) ELSE X11.SetClipRectangles(X11.display, Gc, 0, 0, S.ADR(cliprect), 1, X11.YXBanded) END; RETURN Window = X11.secondary END Secondary;  PROCEDURE (p: Picture) DrawStretchedC* (f: Display.Frame; sx, sy, sw, sh, dx, dy, dw, dh, mode: INTEGER);  BEGIN IF Secondary(f) THEN DEC(dy, X11.UBottom) END; p.DrawStretched(sx, sy, sw, sh, dx, dy, dw, dh, mode); X11.SetClipMask(X11.display, Gc, X11.None) (* Turn off clipping *) END DrawStretchedC;  PROCEDURE (p: Picture) DrawC* (f: Display.Frame; x, y, mode: INTEGER);  BEGIN p.DrawStretchedC (f, 0, 0, p.width, p.height, x, y, p.width, p.height, mode) END DrawC;  PROCEDURE InitPictures;  VAR r, g, b, re, gr, bl: INTEGER; xc: X11.Color; dummy: LONGINT; pm: LONGINT; pal: ARRAY 4, 4, 4 OF LONGINT; BEGIN IF X11.depth >= 16 THEN ELSE END END InitPictures;  PROCEDURE (p: Picture) Print* (x, y, destW, destH, mode: INTEGER);  BEGIN Printer.Picture (x, y, destW, destH, mode, S.VAL (LONGINT, p)) (* Printer still open ??? *) END Print;  PROCEDURE RegisterFormat* (loader: Loader);  VAR i: SHORTINT; BEGIN i := 0; WHILE loaders[i] # NIL DO INC(i) END; loaders[i] := loader END RegisterFormat;  PROCEDURE Load* (file: Files.File; pos: LONGINT) : LoadInfo;  VAR i: SHORTINT; li: LoadInfo; loader: Loader; BEGIN i := 0; WHILE (i < maxLoaders) & (li = NIL) DO IF loaders[i] # NIL THEN loader := loaders[i]; li := loader (file, pos) END; INC(i) END; RETURN li END Load;  PROCEDURE BmpLoader (f: Files.File; pos: LONGINT) : LoadInfo;  VAR r: Files.Rider; li: LoadInfo; id1, id2: CHAR; BEGIN Files.Set (r, f, pos); Files.Read (r, id1); Files.Read (r, id2); IF (id1 # 'B') OR (id2 # 'M') THEN RETURN NIL END; NEW (li); li.res := needData; li.usedBytes := 0; li.picture := NIL; Files.Set (li.r, f, pos); RETURN li END BmpLoader;  PROCEDURE (li: LoadInfo) Completed*;  (** must be called after last call of LoadInfo.Do *) BEGIN IF ASH(1, li.picture.depth) >= X11.nofcol THEN Dither(li.picture) END END Completed;  PROCEDURE (li: LoadInfo) Do*;  VAR pos: LONGINT; BEGIN IF li.res # error THEN pos := Files.Pos (li.r); IF li.picture = NIL THEN NEW (li.picture) END; li.picture.Load (li.r, li.res); li.picture.Update (NIL, 0, 0, li.picture.width, li.picture.height); li.usedBytes := Files.Pos (li.r) - pos END END Do;  PROCEDURE CreateGC;  BEGIN Gc := X11.CreateGC(X11.display, X11.primary, 0, 0); IF Gc = 0 THEN HALT(45) END ; X11.SetPlaneMask(X11.display, Gc, X11.planesMask); X11.SetGraphicsExposures(X11.display, Gc, X11.True); X11.SetBackground(X11.display, Gc, X11.background) END CreateGC;  PROCEDURE ConvertText* (font : Display.Font; text : ARRAY OF CHAR; len : LONGINT; VAR bits: BitField; VAR dx, dy: INTEGER);  VAR bytes : POINTER TO ARRAY OF S.BYTE; oneBit : S.BYTE; help : SHORTINT; ret, fieldlen, w, i, j, hBitmap, hdcMem : LONGINT; dim : RECORD dx, miny, maxy : INTEGER END ; h, curx: INTEGER; pix: X11.Pixmap; xfont: X11.Font; xmet: X11.MetricDesc; pat: Display.Pattern; xpat: X11.Pattern; ximg: X11.Image; BEGIN (*---- filter out all tabs and stop at first CR/LF *) i := 0; WHILE (text[i] # 0X) & (text[i] # CR) & (text[i] # LF) DO IF text[i] = TAB THEN text[i] := ' ' END ; INC(i) END ; text[i] := 0X; len := i; (*---- open a bitmap with dimensions of text, write text into bitmap *) xfont := S.VAL(X11.Font, font); dim.dx := 0; dim.miny := 0; dim.maxy := 0; FOR i := 0 TO len - 1 DO xmet := xfont.metrics[ORD(text[i])]; dim.dx := dim.dx + xmet.dx; h := xmet.p.h + xmet.y; IF xmet.y < dim.miny THEN dim.miny := xmet.y END; IF h > dim.maxy THEN dim.maxy := h END END; X11.SetForeground(X11.display, Gc, X11.foreground); X11.SetBackground(X11.display, Gc, X11.background); IF X11.colorClass = X11.color THEN X11.SetFunction(X11.display, Gc, X11.GXcopy); ELSE X11.SetFunction(X11.display, Gc, X11.GXequiv); END; pix := X11.CreatePixmap(X11.display, X11.primary, dim.dx, dim.maxy - dim.miny, X11.depth); curx := 0; FOR i := 0 TO len - 1 DO xmet := xfont.metrics[ORD(text[i])]; X11.CopyPlane(X11.display, xmet.p.pixmap, pix, Gc, xmet.p.x, xmet.p.y, xmet.p.w, xmet.p.h, curx + xmet.x, dim.maxy - xmet.p.h - xmet.y, 1); curx := curx + xmet.dx END; X11.CopyPlane(X11.display, pix, X11.primary, Gc, 0, 0, dim.dx, dim.maxy - dim.miny, 50, 50, 1); (*---- assertion : text written in a bitmap *) (*---- now scan the bitmap for the text pixels *) dx := SHORT(dim.dx); dy := SHORT(dim.maxy-dim.miny); NEW(bits, dx*dy); ximg := X11.GetImage(X11.display, pix, 0, 0, dim.dx, dim.maxy - dim.miny, 1, X11.XYPixmap); FOR i := 0 TO dy - 1 DO FOR j := 0 TO dx - 1 DO bits[(i * dx) + j] := (X11.GetPixel(ximg, j, i)) = 1; END END END ConvertText;  PROCEDURE (p: Picture) SetText (bits: BitField; dx, dy, x, y, mode : INTEGER);  VAR i, j : INTEGER; BEGIN ASSERT (bits # NIL); FOR i := 0 TO dy - 1 DO FOR j := 0 TO dx - 1 DO IF bits[(i * dx) + j] THEN p.SetPixel(x + j, y + dy - i, mode); END END END END SetText;  PROCEDURE (p: Picture) InsertText* (s: ARRAY OF CHAR; len: INTEGER; x, y, mode: INTEGER; f: Fonts.Font);  VAR bits: BitField; dx, dy: INTEGER; BEGIN ConvertText(f.raster, s, len, bits, dx, dy); p.SetText(bits, dx, dy, x, y, mode) END InsertText;  PROCEDURE (p: Picture) SetScanLine* (VAR data: ARRAY OF CHAR; y, h: INTEGER);  VAR dstRowStart, rowBytes, base: LONGINT; ver, hor, last: INTEGER; BEGIN IF (p.depth = 32) OR (p.depth = 24) THEN ASSERT(LEN(data) >= 4 * p.width); FOR ver := 0 TO h - 1 DO FOR hor := 0 TO p.width - 1 DO p.SetColorRGB(ORD(data[4 * hor]), ORD(data[4 * hor + 1]), ORD(data[4 * hor + 2])); p.SetPixel(hor, y + ver, Display.replace) END END ELSE ASSERT(LEN(data) >= p.width); IF p.depth <= 8 THEN FOR ver := 0 TO h - 1 DO FOR hor := 0 TO p.width - 1 DO p.SetColorIdx(ORD(data[hor])); p.SetPixel(hor, y + ver, Display.replace) END END END END END SetScanLine;  PROCEDURE (p: Picture) GetScanLine* (VAR data: ARRAY OF CHAR; y: INTEGER);  VAR hor, col, r, g, b: INTEGER; BEGIN IF p.depth = 32 THEN ASSERT(LEN(data) >= 4 * p.width); FOR hor := 0 TO p.width - 1 DO p.GetPixelRGB(hor, y, r, g, b); data[4 * hor] := CHR(r); data[4 * hor + 1] := CHR(g); data[4 * hor + 2] := CHR(b); data[4 * hor + 3] := CHR(0) END ELSIF p.depth = 24 THEN ASSERT(LEN(data) >= 3 * p.width); FOR hor := 0 TO p.width - 1 DO p.GetPixelRGB(hor, y, r, g, b); data[3 * hor] := CHR(r); data[3 * hor + 1] := CHR(g); data[3 * hor + 2] := CHR(b) END ELSE ASSERT(LEN(data) >= p.width); IF p.depth <= 8 THEN FOR hor := 0 TO p.width - 1 DO p.GetPixelIdx(hor, y, col); data[hor] := CHR(col) END END END END GetScanLine;  BEGIN CreateGC; InitPictures; loaders[maxLoaders - 1] := BmpLoader; (* cacheHits := 0; cacheMisses := 0; *) useCache := FALSE;  END Pictures.