ui/src/winvbt/WinScrnPixmap.m3


Copyright (C) 1994, Digital Equipment Corp.
Digital Internal Use Only
                                                                           
       Created on Tue Jan 17 16:51:19 PST 1995 by najork                   

UNSAFE MODULE WinScrnPixmap;

IMPORT Axis, Palette, Pixmap, Point, Rect, ScrnPixmap, TrestleComm, VBTRep,
       WinDef, WinGDI, WinScreenType, WinScreenTypePrivate, WinTrestle,
       WinUser, Word;

IMPORT Ctypes, Fmt, IO;

CONST
  True = 1;

<* PRAGMA LL *>

EXCEPTION FatalError;
<* FATAL FatalError *>

TYPE
  T = ScrnPixmap.T BRANDED OBJECT
    st: WinScreenType.T;
  OVERRIDES
    localize := Localize;
    unload   := Unload;
    free     := Free;
  END;

PROCEDURE Localize (self: T; READONLY rect: Rect.T): ScrnPixmap.Raw
    RAISES {TrestleComm.Failure} =
  VAR
    id    := self.id;
    hwnd  : WinDef.HWND;
    hdc   : WinDef.HDC;
    hbmp  : WinDef.HBITMAP;
    status: INTEGER;
    res   : ScrnPixmap.Raw;
    bmi   : WinGDI.BITMAPINFO;
    pixels: REF ARRAY OF WinGDI.RGBQUAD;
    k     : INTEGER;
  BEGIN
    IF id = SolidPixmap THEN
      RETURN rawSolid
    END;

    WITH r  = Rect.Meet(rect, self.bounds),
         st = self.st DO

      IF Rect.IsEmpty (r) THEN
        RETURN NIL;
      END;

      IF id < 0 THEN
        id := SolidPixmap - id;
      END;

      WinTrestle.Enter (st.trsl);
      TRY
        WITH pmr = st.pmtable[id] DO
          <* ASSERT pmr.domain = self.bounds *>
          (* ... if that's true, can we do away with pmr.domain? *)
          hbmp := pmr.hbmp;
        END;
      FINALLY
        WinTrestle.Exit (st.trsl)
      END;

      (* Examine the depth *)
      hwnd := WinUser.GetDesktopWindow ();
      <* ASSERT hwnd # NIL *>
      hdc := WinUser.GetDC (hwnd);
      <* ASSERT hdc # NIL *>

      WITH height = Rect.VerSize (self.bounds),
           width  = Rect.HorSize (self.bounds),
           bmih   = bmi.bmiHeader DO
        bmi.bmiHeader.biSize := BYTESIZE(WinGDI.BITMAPINFOHEADER);
        bmi.bmiHeader.biBitCount := 0;
        status := WinGDI.GetDIBits (hdc,
                                    hbmp,
                                    0,          (* start at scan line 0 *)
                                    height,     (* copy "height" lines *)
                                    NIL,        (* ... that is, don't copy *)
                                    ADR (bmi),  (* ... just fill in bmi *)
                                    WinGDI.DIB_RGB_COLORS);
        <* ASSERT status = True *>

        <* ASSERT bmih.biWidth = width *>
        <* ASSERT bmih.biHeight = height *>

        IF bmih.biBitCount = 1 THEN
          res := ScrnPixmap.NewRaw (1, r);
        ELSE
          res := ScrnPixmap.NewRaw (BITSIZE (WinDef.COLORREF), r);
        END;

        bmih.biBitCount := 32;
        bmih.biCompression := WinGDI.BI_RGB;

        pixels := NEW (REF ARRAY OF WinGDI.RGBQUAD, height * width);
        status := WinGDI.GetDIBits (hdc,
                                    hbmp,
                                    0,             (* start at scan line 0 *)
                                    height,        (* copy "height" lines *)
                                    ADR(pixels[0]),(* into "pixels" *)
                                    ADR (bmi),
                                    WinGDI.DIB_RGB_COLORS);
        <* ASSERT status = height *>

        <* ASSERT bmih.biBitCount = BITSIZE (WinDef.COLORREF) *>
        <* ASSERT bmih.biWidth = Rect.HorSize (self.bounds) *>
        <* ASSERT bmih.biHeight = Rect.VerSize (self.bounds) *>
      END;

      (* Copy "pixels" into "res" *)
      k := 0;
      FOR v := self.bounds.south - 1 TO self.bounds.north BY -1 DO
        FOR h := self.bounds.west TO self.bounds.east - 1 DO
          WITH pt = Point.T {h, v} DO
            IF Rect.Member (pt, r) THEN
              IF res.depth = 1 THEN
                IF pixels[k] = WinGDI.RGBQUAD {0, 0, 0, 0} THEN
                  res.set (pt, 0);
                ELSE
                  res.set (pt, 1);
                END;
              ELSE
                WITH p   = pixels[k],
                     col = WinGDI.RGB (p.rgbRed, p.rgbGreen, p.rgbBlue) DO
                  res.set (pt, col);
                END;
              END;
            END;
            INC (k);
          END;
        END;
      END;

      status := WinUser.ReleaseDC (hwnd, hdc);
      <* ASSERT status = True *>

    END;
    RETURN res;
  END Localize;
----------------------------------------------------------------------------- The spec in ScrnPixmap.i3 states:

The method call pm.unload() causes pm to become anonymous.

The X version (XScrnPxmp.Unregister) doesn't do anything. So, we do the same. -----------------------------------------------------------------------------

PROCEDURE Unload (<*UNUSED*> self: T) =
  BEGIN
    (* do nothing *)
  END Unload;

PROCEDURE Free (self: T) RAISES {TrestleComm.Failure} =
  VAR
    id     := self.id;
    st     := self.st;
    status : WinDef.BOOL;
  BEGIN
    IF id = SolidPixmap THEN
      RETURN;
    END;
    IF id < 0 THEN
      id := SolidPixmap - id;
    END;
    WinTrestle.Enter (st.trsl);
    TRY
      WITH hbitmap = st.pmtable[id].hbmp DO
        IF hbitmap # NIL THEN
          status := WinGDI.DeleteObject (hbitmap);
          <* ASSERT status = True *>
          hbitmap := NIL;
        END;
      END;
    FINALLY
      WinTrestle.Exit (st.trsl);
    END;
  END Free;
***************************************************************************

TYPE
  Oracle = ScrnPixmap.Oracle BRANDED OBJECT
    st: WinScreenType.T;
  OVERRIDES
    load    := Load;
    list    := List;
    lookup  := Lookup;
    builtIn := BuiltIn;
  END;

PROCEDURE Load (                    self: Oracle;
                           READONLY pm  : ScrnPixmap.Raw;
                <*UNUSED*>          nm  : TEXT := NIL): ScrnPixmap.T
    RAISES {TrestleComm.Failure} =
  BEGIN
    WITH st = self.st DO
      WinTrestle.Enter (st.trsl);
      TRY
        IF pm.depth # 1 AND pm.depth # st.depth THEN
          RAISE FatalError;
        END;
        RETURN NewPixmap (st, PixmapFromRaw (st, pm), pm.bounds, pm.depth);
      FINALLY
        WinTrestle.Exit (st.trsl);
      END;
    END;
  END Load;

PROCEDURE DumpPixmap (pm: ScrnPixmap.T) =
  BEGIN
    WITH st = NARROW (pm, T).st DO
      IO.Put ("WinPixmap.T {\n");
      IO.Put ("  id := " & Fmt.Int (pm.id) & "\n");
      IO.Put ("  depth := " & Fmt.Int (pm.depth) & "\n");
      IO.Put ("  bounds := " & Fmt_Rect(pm.bounds) & "\n");
      IF st = st.bits THEN
        IO.Put ("  st := a monochrome screen type\n");
      ELSE
        IO.Put ("  st := a color screen type\n");
      END;
    END;
  END DumpPixmap;

PROCEDURE DumpPixmapRecord (pmr: PixmapRecord) =
  BEGIN
    IO.Put ("WinScrnPixmap.PixmapRecord{\n");
    IO.Put ("  hbmp   := " & Fmt_Addr (pmr.hbmp)   & "\n");
    IO.Put ("  domain := " & Fmt_Rect (pmr.domain) & "\n");
    IO.Put ("}\n");
    VAR
      bitmap: WinGDI.BITMAP;
      sz    : Ctypes.int;
    BEGIN
      sz := WinGDI.GetObject(pmr.hbmp, BYTESIZE (bitmap), ADR(bitmap));
      IF sz = 0 THEN
        IO.Put ("could not get dimensions of bitmap!\n");
      ELSE
        IO.Put ("bmWidth  = " & Fmt.Int(bitmap.bmWidth));
        IO.Put ("bmHeight = " & Fmt.Int(bitmap.bmHeight));
      END;
    END;
  END DumpPixmapRecord;

PROCEDURE DumpRaw (pm: ScrnPixmap.Raw) =
  VAR
    dom := pm.bounds;
  BEGIN
    IO.Put ("ScrnPixmap.Raw: \n");
    IO.Put ("   depth = " & Fmt.Int (pm.depth) & "\n");
    IO.Put ("   bounds = {" & Fmt_Rect (dom) & "\n");
    IO.Put ("   bitsPerPixel = " & Fmt.Int (pm.bitsPerPixel) & "\n");
    IO.Put ("   wordsPerRow = " & Fmt.Int (pm.wordsPerRow) & "\n");
    IO.Put ("   One row of pixels from the middle:\n");
    IF pm.pixelOrder = ScrnPixmap.ByteOrder.MSBFirst THEN
      IO.Put ("   byteOrder = MSBFirst\n");
    ELSE
      IO.Put ("   byteOrder = LSBFirst\n");
    END;
    IO.Put ("   westRounded = " & Fmt.Int (pm.westRounded) & "\n");
    FOR v := dom.north TO MIN (dom.north + 19, dom.south - 1) DO
      IO.Put("   row " & Fmt.Pad (Fmt.Int(v),2) & ": ");
      FOR h := dom.west TO MIN (dom.west + 19, dom.east - 1) DO
        IO.Put(Fmt.Pad(Fmt.Int(pm.get(Point.T{h,v}), base := 16),2,'0') & " ");
      END;
      IO.Put ("\n");
    END;
  END DumpRaw;

PROCEDURE Fmt_Rect (r: Rect.T): TEXT =
  BEGIN
    RETURN "Rect.T{" &
           Fmt.Int(r.west) & "," &
           Fmt.Int(r.east) & "," &
           Fmt.Int(r.north) & "," &
           Fmt.Int(r.south) & "}";
  END Fmt_Rect;

PROCEDURE Fmt_Addr (a: ADDRESS): TEXT =
  BEGIN
    WITH i = LOOPHOLE (a, INTEGER) DO
      RETURN Fmt.Int (i, base := 16);
    END;
  END Fmt_Addr;
----------------------------------------------------------------------------- The spec in ScrnPixmap.i3 states:

The method call st.pixmap.list(pat, maxResults) returns the names of all pixmaps owned by st that match the pattern pat. The list of results may be truncated to length maxResults. A * matches any number of characters and a ? matches any single character.

The X version (XScrnPxmp.PixmapList), however, simply always returns NIL. For now, I do the same ... -----------------------------------------------------------------------------

PROCEDURE List (<*UNUSED*> self      : Oracle;
                <*UNUSED*> pat       : TEXT;
                <*UNUSED*> maxResults: CARDINAL): REF ARRAY OF TEXT =
  BEGIN
    RETURN NIL
  END List;
----------------------------------------------------------------------------- The spec in ScrnPixmap.i3 states:

The method call st.pixmap.lookup(name) return the pixmap with the given name, or NIL if no pixmap has this name.

The X version (XScrnPxmp.PixmapLookup), however, simply always returns NIL. For now, I do the same ... -----------------------------------------------------------------------------

PROCEDURE Lookup (<*UNUSED*> self: Oracle;
                  <*UNUSED*> name: TEXT): ScrnPixmap.T =
  BEGIN
    RETURN NIL;
  END Lookup;

PROCEDURE BuiltIn (self: Oracle; pm: Pixmap.Predefined): ScrnPixmap.T =
  VAR
    res: ScrnPixmap.T;
  BEGIN
    IF self.st.bits # self. st THEN
      res := Palette.ResolvePixmap (self.st.bits, Pixmap.T {pm});
      RETURN res;
    END;
    TRY
      CASE pm OF
      | Pixmap.Solid.pm =>
        WITH res = Load (self, rawSolid) DO
          res.id := SolidPixmap;
          RETURN res;
        END;
      | Pixmap.Gray.pm =>
        RETURN Load (self, rawGray);
      | Pixmap.Empty.pm =>
        RETURN Load (self, rawEmpty);
      ELSE
        RAISE FatalError;
      END;
    EXCEPT
      TrestleComm.Failure =>
      RETURN NEW (T, id := 0, depth := 1, bounds := Rect.Empty);
    END;
  END BuiltIn;
*************************************************************************** Exported procedures ***************************************************************************

PROCEDURE NewOracle(st : WinScreenType.T): ScrnPixmap.Oracle =
  BEGIN
    RETURN NEW (Oracle, st := st);
  END NewOracle;

PROCEDURE PixmapDomain (st: WinScreenType.T; pmId: INTEGER): Rect.T =
  BEGIN
    IF pmId < 0 THEN
      IF pmId = SolidPixmap THEN
        RETURN rawSolid.bounds
      END;
      pmId := SolidPixmap - pmId;
      st := st.bits;
    END;
    IF pmId < NUMBER (st.pmtable^) THEN
      RETURN st.pmtable[pmId].domain;
    ELSE
      RETURN Rect.Empty;
    END;
  END PixmapDomain;

* The xvbt version of this function is quite a hack: The actual image data * of a ScrnPixmap.Raw is stored in a field pixels. It just so happens * that the memory layout of pixels is identical to the layout expected by * the data field of an X.XImage record. So, the xvbt version simply * creates an XImage, loopholes the pixels field into the data field, * then creates an X.Pixmap, paints the X.XImage onto the X.Pixmap, * and returns the X pixmap. * * The Windows version currently deals only with monochrome bitmaps * (which makes sense, since I didn't implement colors yet either)

PROCEDURE PixmapFromRaw (st: WinScreenType.T;
                         pm: ScrnPixmap.Raw): WinDef.HBITMAP =
  <* LL.sup = st.trsl *>

  PROCEDURE ConvertMonochrome (pm: ScrnPixmap.Raw): WinDef.HBITMAP =
    TYPE
      WinWord = Ctypes.unsigned_short;
      Bit     = BITS 1 FOR [0..1];
      Byte    = BITS 8 FOR ARRAY [0..7] OF Bit;
      TwoByte = BITS 16 FOR ARRAY [0..1] OF Byte;
    CONST
      WinWordSize = BITSIZE (WinWord);
    BEGIN
      WITH pix_width  = pm.bounds.east  - pm.bounds.west,
           pix_height = pm.bounds.south - pm.bounds.north,
           word_width = (pix_width - 1) DIV WinWordSize + 1,
           words      = NEW (REF ARRAY OF WinWord, word_width * pix_height) DO
        (* first, let's blank the array *)
        FOR i := 0 TO word_width * pix_height - 1 DO
          words[i] := 0;
        END;
        (* Next, let's transfer the bits from pm.pixels to bits *)
        FOR v := 0 TO pix_height - 1 DO
          FOR h := 0 TO pix_width - 1 DO
            WITH pt  = Point.T{pm.bounds.west + h, pm.bounds.north + v},
                 word = v * word_width + h DIV WinWordSize,
                 byte = (h MOD WinWordSize) DIV 8,
                 bit  = 7 - h MOD 8 DO
              LOOPHOLE (words[word], TwoByte)[byte][bit] := pm.get(pt);
            END;
          END;
        END;
        WITH res = WinGDI.CreateBitmap (pm.bounds.east - pm.bounds.west,
                                        pm.bounds.south - pm.bounds.north,
                                        1, 1, ADR(words[0])) DO
          <* ASSERT res # NIL *>
          RETURN res;
        END;
      END;
    END ConvertMonochrome;

  PROCEDURE ConvertColor (st: WinScreenType.T;
                          pm: ScrnPixmap.Raw): WinDef.HBITMAP =
    VAR
      hwnd   : WinDef.HWND;
      hdc    : WinDef.HDC;
      hbmp   : WinDef.HBITMAP;
      pixels : REF ARRAY OF WinGDI.RGBQUAD;
      k      : INTEGER;
      status : WinDef.BOOL;
      bmi    : WinGDI.BITMAPINFO;
    BEGIN
      hwnd := WinUser.GetDesktopWindow ();
      <* ASSERT hwnd # NIL *>
      hdc := WinUser.GetDC (hwnd);
      <* ASSERT hdc # NIL *>

      pixels := NEW (REF ARRAY OF WinGDI.RGBQUAD,
                     (pm.bounds.south - pm.bounds.north) *
                     (pm.bounds.east - pm.bounds.west));
      k := 0;
      FOR i := pm.bounds.south - 1 TO pm.bounds.north BY -1 DO
        FOR j := pm.bounds.west TO pm.bounds.east - 1 DO
          WITH pixel = pm.get(Point.T{j,i}),
               red   = WinGDI.GetRValue (pixel),
               green = WinGDI.GetGValue (pixel),
               blue  = WinGDI.GetBValue (pixel) DO
            pixels[k] := WinGDI.RGBQUAD {blue, green, red, 0};
          END;
          INC (k);
        END;
      END;

      WITH bmih = bmi.bmiHeader DO
        bmih.biSize          := BYTESIZE(WinGDI.BITMAPINFOHEADER);
        bmih.biWidth         := pm.bounds.east - pm.bounds.west;
        (* Windows NT bug: According to the doc, a negative value for
           biHeight indicates a top-down bitmap, that is, a bitmap that
           starts in the upper-left corner. However, if I actually pass
           a negative value, the bitmap comes out solid black most of the
           time (although at some point, it came out ok ...) *)
        bmih.biHeight        := pm.bounds.south - pm.bounds.north;
        bmih.biPlanes        := 1;   (* always 1 *)
        bmih.biBitCount      := 32;
        bmih.biCompression   := WinGDI.BI_RGB;
        bmih.biSizeImage     := 0;   (* 0 is valid only for BI_RGB *)
        bmih.biXPelsPerMeter := ROUND (st.res[Axis.T.Hor] * 1000.0);
        bmih.biYPelsPerMeter := ROUND (st.res[Axis.T.Ver] * 1000.0);
        bmih.biClrUsed       := 0;   (* bitmap uses all the colors *)
        bmih.biClrImportant  := 0;   (* all colors are important *)

        hbmp := WinGDI.CreateDIBitmap (hdc,
                                       ADR(bmih),
                                       WinGDI.CBM_INIT,
                                       LOOPHOLE (ADR (pixels[0]),
                                                 WinDef.LPVOID),
                                       ADR (bmi),
                                       WinGDI.DIB_RGB_COLORS);
      END;

      status := WinUser.ReleaseDC (hwnd, hdc);
      <* ASSERT status = True *>
      RETURN hbmp;
    END ConvertColor;

  BEGIN
    IF Rect.IsEmpty (pm.bounds) THEN
      RETURN NIL ;
    ELSIF pm.depth = 1 AND pm.bitsPerPixel = 1 THEN
      RETURN ConvertMonochrome (pm);
    ELSE
      RETURN ConvertColor (st, pm);
    END;
  END PixmapFromRaw;
*************************************************************************** Private procedures ***************************************************************************

PROCEDURE NewPixmap (         st    : WinScreenType.T;
                              hbmp  : WinDef.HBITMAP;
                     READONLY domain: Rect.T;
                              depth : INTEGER): ScrnPixmap.T =
  <* LL.sup = st.trsl *>
  VAR
    id: INTEGER;
  BEGIN
    IF depth = 1 THEN
      st := st.bits
    END;
    WITH n = NUMBER (st.pmtable^) DO
      IF n = st.pmcount THEN
        WITH new = NEW (REF ARRAY OF PixmapRecord, 2 * n) DO
          SUBARRAY (new^, 0, n) := st.pmtable^;
          st.pmtable := new;
        END;
      END;
    END;
    IF st.bits = st THEN
      id := SolidPixmap - st.pmcount;
    ELSE
      id := st.pmcount;
    END;
    st.pmtable[st.pmcount] := PixmapRecord {hbmp, domain};
    INC(st.pmcount);
    RETURN NEW (T, st := st, id := id, depth := depth,
                bounds := Rect.Sub (domain, Rect.NorthWest (domain)));
        (* Simply passing "domain" screws things up.
           This sounds like a bug somewhere in my code. *)
  END NewPixmap;

VAR
  rawSolid, rawGray, rawEmpty: ScrnPixmap.Raw;

PROCEDURE InitPredefRaws () =
  CONST
    left00 = Word.LeftShift (0, BITSIZE(ScrnPixmap.PixWord) - 2);
    left01 = Word.LeftShift (1, BITSIZE(ScrnPixmap.PixWord) - 2);
    left10 = Word.LeftShift (2, BITSIZE(ScrnPixmap.PixWord) - 2);
    left11 = Word.LeftShift (3, BITSIZE(ScrnPixmap.PixWord) - 2);
  BEGIN
    rawSolid := ScrnPixmap.NewRaw (1, Rect.FromSize (1, 1));
    rawSolid.pixels[rawSolid.offset] := left11;

    rawEmpty := ScrnPixmap.NewRaw (1, Rect.FromSize(1, 1));
    rawEmpty.pixels[rawEmpty.offset] := left00;

    rawGray := ScrnPixmap.NewRaw (1, Rect.FromSize(2, 2));
    rawGray.pixels[rawGray.offset                      ] := left10;
    rawGray.pixels[rawGray.offset + rawGray.wordsPerRow] := left01;
  END InitPredefRaws;

BEGIN
  InitPredefRaws();
END WinScrnPixmap.