Copyright (C) 1994, Digital Equipment Corp.
by Steve Glassman, Mark Manasse and Greg Nelson
<*PRAGMA LL*> UNSAFE MODULE; IMPORT ScrnColorMap, TrestleComm, Word, X, XClient, XScreenType, XScrnTpRep, TrestleOnX, Math, Ctypes; TYPE ColorMapOracle = ScrnColorMap.Oracle OBJECT st : XScreenType.T; defaultCM: XColorMap; METHODS <* LL.sup = SELF.st.trsl *> init (st: XScreenType.T; READONLY vinfo: X.XVisualInfo): ColorMapOracle RAISES {TrestleComm.Failure} := InitColorMapOracle; OVERRIDES standard := ColorMapDefault; new := ColorMapNew; list := ColorMapList; lookup := ColorMapLookup END; PROCEDURE XScrnCmap NewOracle (scrn: XScreenType.T; READONLY vinfo: X.XVisualInfo): ScrnColorMap.Oracle RAISES {TrestleComm.Failure} = BEGIN RETURN NEW(ColorMapOracle).init(scrn, vinfo) END NewOracle; TYPE Prim = ScrnColorMap.Primary; XColorMap = ScrnColorMap.T OBJECT st : XScreenType.T; direct: BOOLEAN; xid : X.Colormap; OVERRIDES fromRGB := ColorMapFromRGB; new := ColorMapCube; read := ColorMapRead; write := ColorMapWrite; free := ColorMapFreeCube; END;
For all v: VBT.T, all cm: XColorMap, cm < v
PROCEDUREColorMapID (cm: ScrnColorMap.T): X.Colormap = BEGIN TYPECASE cm OF NULL => RETURN X.None | XColorMap (xcm) => RETURN xcm.xid ELSE RETURN X.None END END ColorMapID; PROCEDUREColorMapFromRGB (cm : XColorMap; rgb : ScrnColorMap.RGB; mode: ScrnColorMap.Mode ): ScrnColorMap.Pixel RAISES {ScrnColorMap.Failure, TrestleComm.Failure} = VAR xcol: X.XColor; ent : ScrnColorMap.Entry; trsl := cm.st.trsl; BEGIN TRY IF cm.direct AND mode = ScrnColorMap.Mode.Accurate THEN mode := ScrnColorMap.Mode.Normal END; IF mode # ScrnColorMap.Mode.Accurate THEN rgb.r := FLOAT(ROUND(rgb.r * FLOAT(cm.ramp.last[Prim.Red]))) / FLOAT( cm.ramp.last[Prim.Red]); rgb.g := FLOAT(ROUND(rgb.g * FLOAT(cm.ramp.last[Prim.Green]))) / FLOAT(cm.ramp.last[Prim.Green]); rgb.b := FLOAT(ROUND(rgb.b * FLOAT(cm.ramp.last[Prim.Blue]))) / FLOAT(cm.ramp.last[Prim.Blue]); END; ent.rgb := rgb; XColorFromEntry(xcol, ent); TrestleOnX.Enter(trsl); TRY IF mode # ScrnColorMap.Mode.Accurate AND cm.ramp.base # -1 THEN ent.pix := cm.ramp.base; INC(ent.pix, cm.ramp.mult[Prim.Red] * ROUND( rgb.r * FLOAT(cm.ramp.last[Prim.Red]))); INC(ent.pix, cm.ramp.mult[Prim.Green] * ROUND( rgb.g * FLOAT(cm.ramp.last[Prim.Green]))); INC(ent.pix, cm.ramp.mult[Prim.Blue] * ROUND( rgb.b * FLOAT(cm.ramp.last[Prim.Blue]))); ELSE IF X.XAllocColor(trsl.dpy, cm.xid, ADR(xcol)) = 0 THEN RAISE ScrnColorMap.Failure END; ent.pix := xcol.pixel END FINALLY TrestleOnX.Exit(trsl) END; EXCEPT X.Error => RAISE TrestleComm.Failure END; RETURN ent.pix END ColorMapFromRGB; PROCEDUREColorMapRead (cm: XColorMap; VAR res: ARRAY OF ScrnColorMap.Entry) RAISES {TrestleComm.Failure} = VAR xres := NEW(UNTRACED REF ARRAY OF X.XColor, NUMBER(res)); BEGIN TRY TRY IF NUMBER(res) = 0 THEN RETURN END; FOR i := 0 TO LAST(res) DO xres[i].pixel := res[i].pix; xres[i].flags := X.DoRed + X.DoGreen + X.DoBlue END; TrestleOnX.Enter(cm.st.trsl); TRY X.XQueryColors(cm.st.trsl.dpy, cm.xid, ADR(xres[0]), NUMBER(res)); FOR i := 0 TO LAST(res) DO EntryFromXColor(res[i], xres[i]) END FINALLY TrestleOnX.Exit(cm.st.trsl) END FINALLY DISPOSE(xres) END EXCEPT X.Error => RAISE TrestleComm.Failure END; END ColorMapRead; PROCEDUREColorMapWrite ( cm : XColorMap; READONLY new: ARRAY OF ScrnColorMap.Entry) RAISES {ScrnColorMap.Failure, TrestleComm.Failure} = BEGIN IF cm.readOnly THEN RAISE ScrnColorMap.Failure END; InnerColorMapWrite(cm, new) END ColorMapWrite; PROCEDUREColorMapCube (cm: XColorMap; d: CARDINAL): ScrnColorMap.Cube RAISES {ScrnColorMap.Failure, TrestleComm.Failure} = VAR res : ScrnColorMap.Cube; pm : UNTRACED REF ARRAY OF INTEGER; trsl := cm.st.trsl; dpy := trsl.dpy; BEGIN TRY IF cm.readOnly THEN RAISE ScrnColorMap.Failure END; pm := NEW(UNTRACED REF ARRAY OF INTEGER, MAX(d, 1)); TRY TrestleOnX.Enter(trsl); TRY IF X.XAllocColorCells( dpy, cm.xid, X.False, ADR(pm[0]), d, ADR(res.lo), 1) = 0 THEN RAISE ScrnColorMap.Failure END; res.hi := res.lo; FOR i := 0 TO d - 1 DO INC(res.hi, pm[i]) END FINALLY TrestleOnX.Exit(trsl) END FINALLY DISPOSE(pm) END; EXCEPT X.Error => RAISE TrestleComm.Failure END; RETURN res END ColorMapCube; PROCEDUREColorMapFreeCube (cm: XColorMap; READONLY cb: ScrnColorMap.Cube) RAISES {TrestleComm.Failure} = VAR pm : UNTRACED REF ARRAY OF INTEGER; trsl := cm.st.trsl; dpy := trsl.dpy; BEGIN TRY pm := NEW(UNTRACED REF ARRAY OF INTEGER, cm.depth); TRY TrestleOnX.Enter(trsl); TRY X.XFreeColors(dpy, cm.xid, ADR(cb.lo), 1, cb.hi - cb.lo) FINALLY TrestleOnX.Exit(trsl) END FINALLY DISPOSE(pm) END EXCEPT X.Error => RAISE TrestleComm.Failure END; END ColorMapFreeCube; PROCEDUREInnerColorMapWrite ( cm : XColorMap; READONLY new: ARRAY OF ScrnColorMap.Entry) RAISES {ScrnColorMap.Failure, TrestleComm.Failure} = VAR trsl := cm.st.trsl; dpy := trsl.dpy; xcolor : X.XColor; xcolors: UNTRACED REF ARRAY OF X.XColor; BEGIN TRY TrestleOnX.Enter(trsl); TRY IF NUMBER(new) = 1 THEN XColorFromEntry(xcolor, new[0]); X.XStoreColor(dpy, cm.xid, ADR(xcolor)) ELSE xcolors := NEW(UNTRACED REF ARRAY OF X.XColor, NUMBER(new)); TRY FOR i := 0 TO LAST(new) DO XColorFromEntry(xcolors[i], new[i]) END; X.XStoreColors(dpy, cm.xid, ADR(xcolors[0]), NUMBER(new)) FINALLY DISPOSE(xcolors) END END FINALLY TrestleOnX.Exit(trsl) END EXCEPT X.Error => RAISE TrestleComm.Failure END; END InnerColorMapWrite; <* UNUSED *> PROCEDURESqrt (x: REAL): REAL = CONST epsilon = 0.25 / FLOAT(Word.Shift(1, 30)); VAR r : REAL; scale := 0; BEGIN IF x <= epsilon THEN RETURN 0.0 END; WHILE x < 0.25 DO INC(scale); x := 4.0 * x END; r := (x + 1.0) / 2.0; FOR i := 1 TO 5 DO r := (r + x / r) / 2.0 END; IF scale # 0 THEN r := r / FLOAT(Word.Shift(1, scale)) END; RETURN r END Sqrt; <* UNUSED *> PROCEDURECbrt (x: REAL): REAL = CONST epsilon = 1.0 / FLOAT(Word.Shift(1, 24)); VAR r : REAL; scale := 0; BEGIN IF x <= epsilon THEN RETURN 0.0 END; WHILE x < 0.125 DO INC(scale); x := 8.0 * x END; r := (x + 2.0) / 3.0; FOR i := 1 TO 5 DO r := (2.0 * r + x / (r * r)) / 3.0 END; IF scale # 0 THEN r := r / FLOAT(Word.Shift(1, scale)) END; RETURN r END Cbrt; CONST Gamma = 2.4D0; GammaInverse = 1.0D0 / Gamma; PROCEDUREXColorFromEntry (VAR xcolor: X.XColor; READONLY ent : ScrnColorMap.Entry) RAISES {ScrnColorMap.Failure} = CONST Scale = FLOAT(LAST(Card16), LONGREAL); DoAll = X.DoRed + X.DoGreen + X.DoBlue; BEGIN IF ent.rgb.r < 0.0 OR ent.rgb.r > 1.0 OR ent.rgb.g < 0.0 OR ent.rgb.g > 1.0 OR ent.rgb.b < 0.0 OR ent.rgb.b > 1.0 THEN RAISE ScrnColorMap.Failure END; xcolor.pixel := ent.pix; (* VAR rr := Cbrt(ent.rgb.r); gg := Cbrt(ent.rgb.g); bb := Cbrt(ent.rgb.b); BEGIN xcolor.red := ROUND(Scale * rr * rr); xcolor.green := ROUND(Scale * gg * gg); xcolor.blue := ROUND(Scale * bb * bb) END; *) VAR rr := FLOAT(ent.rgb.r, LONGREAL); gg := FLOAT(ent.rgb.g, LONGREAL); bb := FLOAT(ent.rgb.b, LONGREAL); BEGIN xcolor.red := ROUND(Scale * Math.pow(rr, GammaInverse)); xcolor.green := ROUND(Scale * Math.pow(gg, GammaInverse)); xcolor.blue := ROUND(Scale * Math.pow(bb, GammaInverse)); END; xcolor.flags := DoAll END XColorFromEntry; PROCEDUREEntryFromXColor (VAR ent : ScrnColorMap.Entry; READONLY xcolor: X.XColor ) = CONST Scale = FLOAT(LAST(Card16), LONGREAL); BEGIN ent.pix := xcolor.pixel; VAR rr := FLOAT(xcolor.red, LONGREAL) / Scale; gg := FLOAT(xcolor.green, LONGREAL) / Scale; bb := FLOAT(xcolor.blue, LONGREAL) / Scale; BEGIN (* ent.rgb.r := rr * Sqrt(rr); ent.rgb.g := gg * Sqrt(gg); ent.rgb.b := bb * Sqrt(bb) *) ent.rgb.r := FLOAT(Math.pow(rr, Gamma)); ent.rgb.g := FLOAT(Math.pow(gg, Gamma)); ent.rgb.b := FLOAT(Math.pow(bb, Gamma)); END END EntryFromXColor; TYPE Card16 = BITS 16 FOR [0 .. 16_ffff]; PROCEDUREInitColorMapOracle ( orc : ColorMapOracle; st : XScreenType.T; READONLY vinfo: X.XVisualInfo ): ColorMapOracle RAISES {TrestleComm.Failure} <* LL.sup = st.trsl *> = PROCEDURE RampMask (VAR ramp : ScrnColorMap.Ramp; mask : Ctypes.unsigned_long; index: Prim ) = VAR mult := Word.And(mask, Word.Not(mask - 1)); BEGIN ramp.mult[index] := mult; ramp.last[index] := Word.Divide(mask, mult); END RampMask; VAR vis := vinfo.visual; xid := X.XDefaultColormap(st.trsl.dpy, st.screenID); class := vis.class; BEGIN TRY orc.st := st; orc.defaultCM := InnerColorMapNew( orc, xid, NIL, class # X.GrayScale AND class # X.PseudoColor, vinfo.depth, direct := class = X.DirectColor); VAR atm := XClient.ToAtom(st.trsl, "RGB_DEFAULT_MAP"); n : Ctypes.int; xsc, xscp: X.XStandardColormapStar; success := X.XGetRGBColormaps( st.trsl.dpy, st.root, ADR(xsc), ADR(n), atm) # 0; x, y: X.VisualID; BEGIN IF success THEN success := FALSE; xscp := xsc; FOR i := 0 TO n - 1 DO x := xscp.visualid; y := orc.st.visual.visualid; IF x = y THEN success := TRUE; WITH ramp = orc.defaultCM.ramp DO ramp.last[Prim.Red] := xscp.red_max; ramp.last[Prim.Green] := xscp.green_max; ramp.last[Prim.Blue] := xscp.blue_max; ramp.mult[Prim.Red] := xscp.red_mult; ramp.mult[Prim.Green] := xscp.green_mult; ramp.mult[Prim.Blue] := xscp.blue_mult; IF xscp.colormap = xid THEN ramp.base := xscp.base_pixel ELSE ramp.base := -1 END END END; INC(xscp, ADRSIZE(X.XStandardColormap)) END; X.XFree(LOOPHOLE(xsc, Ctypes.char_star)) END; IF NOT success THEN WITH ramp = orc.defaultCM.ramp DO IF class = X.DirectColor OR class = X.TrueColor THEN RampMask(ramp, vis.red_mask, Prim.Red); RampMask(ramp, vis.green_mask, Prim.Green); RampMask(ramp, vis.blue_mask, Prim.Blue); ramp.base := 0 ELSE WITH np = Word.Shift(1, vis.bits_per_rgb) - 1 DO ramp.last[Prim.Red] := np; ramp.last[Prim.Green] := np; ramp.last[Prim.Blue] := np; ramp.base := -1 END; END END END END; EXCEPT X.Error => RAISE TrestleComm.Failure END; RETURN orc END InitColorMapOracle; PROCEDUREColorMapDefault (orc: ColorMapOracle): ScrnColorMap.T RAISES {} = BEGIN RETURN orc.defaultCM END ColorMapDefault; PROCEDUREColorMapList (<*UNUSED*> orc : ColorMapOracle; <*UNUSED*> pat : TEXT; <*UNUSED*> maxResults: CARDINAL ): REF ARRAY OF TEXT RAISES {} = BEGIN RETURN NIL END ColorMapList; PROCEDUREColorMapLookup (<*UNUSED*> orc: ColorMapOracle; <*UNUSED*> pat: TEXT ): ScrnColorMap.T RAISES {} = BEGIN RETURN NIL END ColorMapLookup; PROCEDUREColorMapNew ( orc : ColorMapOracle; nm : TEXT := NIL; <*UNUSED*> preLoaded := TRUE ): ScrnColorMap.T RAISES {TrestleComm.Failure} = VAR nxid: X.Colormap; res : ScrnColorMap.T; BEGIN TRY IF orc.defaultCM.readOnly THEN RETURN orc.defaultCM END; TrestleOnX.Enter(orc.st.trsl); TRY nxid := X.XCreateColormap( orc.st.trsl.dpy, orc.st.root, orc.st.visual, X.AllocNone); res := InnerColorMapNew(orc, nxid, nm, FALSE, orc.defaultCM.depth, orc.defaultCM.direct); res.ramp := orc.defaultCM.ramp; res.ramp.base := -1; RETURN res FINALLY TrestleOnX.Exit(orc.st.trsl) END EXCEPT X.Error => RAISE TrestleComm.Failure END; END ColorMapNew; PROCEDUREInnerColorMapNew ( orc : ColorMapOracle; cm : X.Colormap; <*UNUSED*> nm : TEXT := NIL; readOnly: BOOLEAN; depth : INTEGER; direct : BOOLEAN ): XColorMap = BEGIN RETURN NEW(XColorMap, st := orc.st, xid := cm, readOnly := readOnly, depth := depth, direct := direct) END InnerColorMapNew; BEGIN END XScrnCmap.