<> <> <> <> <<>> <> DIRECTORY Atom USING [GetPName, PutPropOnList], CD USING [Layer, LayerKey, LayerTechnology, Technology], CDColors USING [ColorTable, DisplayMode, DisplayType, globalColors], Commander USING [CommandProc, Register], Convert USING [AppendReal], Imager USING [Color, ConstantColor], ImagerColor USING [ColorFromRGB, HSL, HSLFromRGB, RGB], ImagerColorPrivate USING [ComponentFromColor], PrincOpsUtils USING [], Real USING [Float], Rope USING [ActionType, Map, ROPE], Terminal USING [ChannelValue, ColorValue, Current, GetColor, GetColorBitmapState, Virtual], TerminalIO USING [PutRope], TiogaAccess USING [Create, GetInternalProp, Looks, Put, TiogaChar, WriteFile, Writer]; NectarineTune: CEDAR PROGRAM IMPORTS Atom, CD, CDColors, Commander, Convert, ImagerColor, ImagerColorPrivate, Real, Rope, Terminal, TerminalIO, TiogaAccess ~ BEGIN OPEN Imager, ImagerColor, ImagerColorPrivate, Real; break: SIGNAL = CODE; -- for debugging Blend: TYPE ~ REF BlendRec; BlendRec: TYPE ~ RECORD [count: CD.Layer _ 0, flavours: PACKED ARRAY CD.Layer OF BOOLEAN _ ALL[FALSE]]; <> <> BlendColours: PROC [components: Blend] RETURNS [blended: Color] ~ BEGIN <> <> n: INT _ components.count; comp: PACKED ARRAY CD.Layer OF BOOLEAN _ components.flavours; mix: RGB _ [0, 0, 0]; SELECT n FROM 0 => ERROR; -- should never have been allocated 1 => BEGIN i: CD.Layer _ 0; WHILE NOT comp[i] DO i _ SUCC [i] ENDLOOP; blended _ LayerColour [i] END; ENDCASE => BEGIN poly, diff, well: CD.Layer _ 0; hasCut: BOOL _ FALSE; <> FOR i: CD.Layer IN CD.Layer DO IF comp[i] THEN SELECT CD.LayerKey[i] FROM $pol => poly _ i; $ndif, $pdif => diff _ i; $cut, $cut2 => hasCut _ TRUE; $nwel => well _ i; ENDCASE => NULL; ENDLOOP; <> IF hasCut THEN blended _ ColorFromRGB [[0, 0, 0]] ELSE BEGIN <> IF (poly # 0) AND (diff # 0) THEN BEGIN <> mix _ [1, 1, 0]; n _ PRED [n]; comp[poly] _ comp[diff] _ FALSE END; <> FOR i: CD.Layer IN CD.Layer DO <> IF comp[i] THEN BEGIN v: ImagerColor.RGB ~ RGBFromColor [LayerColour[i]]; IF (i = well) AND (i # 0) THEN NULL; -- not yet decided mix.R _ mix.R + v.R; mix.G _ mix.G + v.G; mix.B _ mix.B + v.B END ENDLOOP; mix.R _ mix.R / n; mix.G _ mix.G / n; mix.B _ mix.B / n; blended _ ColorFromRGB [mix] END END; RETURN [blended] END; -- BlendColours <> RGBFromColor: PROC [c: Color] RETURNS [rgb: RGB] ~ INLINE BEGIN <> WITH c SELECT FROM constant: ConstantColor => BEGIN rgb.R _ ComponentFromColor [constant, $Red]; rgb.G _ ComponentFromColor [constant, $Green]; rgb.B _ ComponentFromColor [constant, $Blue] END; ENDCASE => rgb _ [0.0, 0.0, 0.0]; RETURN [rgb] END; -- RGBFromColor LayerColour: PROC [l: CD.Layer] RETURNS [Color] ~ BEGIN <> original: Color ~ CDColors.globalColors[bit8][normal].cols[l]; RETURN [original] END; -- LayerColour <> document: TiogaAccess.Writer = TiogaAccess.Create []; vanillaLook: TiogaAccess.Looks = ALL [FALSE]; vanillaChar: TiogaAccess.TiogaChar = [0, 0C, vanillaLook, $lead3, FALSE, FALSE, 0, NIL]; symbolLook, charLook, labelLook: TiogaAccess.Looks _ vanillaLook; InitDocument: PROC ~ BEGIN <> rootCharacter: TiogaAccess.TiogaChar _ vanillaChar; -- 1st char written rootCharacter.endOfNode _ TRUE; rootCharacter.deltaLevel _ 1; rootCharacter.propList _ Atom.PutPropOnList [propList: rootCharacter.propList, prop: $Postfix, val: TiogaAccess.GetInternalProp [$Postfix, "11 in pageWidth 8.5 in pageLength"]]; TiogaAccess.Put [document, rootCharacter] END; WriteChar: PROC [c: CHAR, l: TiogaAccess.Looks _ charLook] ~ BEGIN tc: TiogaAccess.TiogaChar _ vanillaChar; tc.char _ c; tc.looks _ l; TiogaAccess.Put [document, tc] END; -- WriteChar WriteTab: PROC [] ~ BEGIN tab: CHAR = 'I - 100B; WriteChar [tab] END; -- WriteTab PutRope: PROC [r: Rope.ROPE, l: TiogaAccess.Looks _ labelLook] ~ BEGIN PutChar: Rope.ActionType ~ {WriteChar [c, l]}; [] _ Rope.Map [base: r, action: PutChar] END; -- PutRope WriteEOL: PROC ~ BEGIN tc: TiogaAccess.TiogaChar _ vanillaChar; tc.endOfNode _ TRUE; TiogaAccess.Put [document, tc] END; -- WriteEOL WriteNewPage: PROC ~ BEGIN tc: TiogaAccess.TiogaChar _ vanillaChar; tc.endOfNode _ TRUE; tc.format _ $pageBreak; TiogaAccess.Put [document, tc] END; -- WriteNewPage WriteBigLead: PROC ~ BEGIN tc: TiogaAccess.TiogaChar _ vanillaChar; tc.endOfNode _ TRUE; tc.format _ $lead3; TiogaAccess.Put [document, tc]; TiogaAccess.Put [document, tc] END; -- WriteBigLead WriteReal: PROC [n: REAL] ~ BEGIN buffer: REF TEXT _ NEW [TEXT]; buffer _ Convert.AppendReal [to: buffer, from: n, precision: 3]; WriteTab []; FOR i: NAT IN [0 .. buffer.length) DO WriteChar [buffer[i]] ENDLOOP END; -- WriteReal <
> FindAllColours: Commander.CommandProc ~ BEGIN <> vt: Terminal.Virtual ~ Terminal.Current []; prevTech: CD.Technology _ NIL; InitDocument []; FOR layer: CD.Layer IN CD.Layer DO tech: CD.Technology ~ CD.LayerTechnology[layer]; key: ATOM _ CD.LayerKey [layer]; rgb: RGB ~ RGBFromColor [LayerColour [layer]]; hsl: HSL ~ HSLFromRGB [rgb]; IF (key # NIL) THEN BEGIN IF (tech # prevTech) THEN BEGIN prevTech _ tech; WriteBigLead []; IF (tech # NIL) THEN PutRope [tech.name] ELSE PutRope ["Unnamed Technology"]; WriteEOL [] END; IF (tech # NIL) THEN {PutRope [tech.name, charLook]; WriteChar ['.]}; PutRope [Atom.GetPName [key]]; WriteTab []; PutRope ["R, G, B: "]; WriteReal [rgb.R]; WriteReal [rgb.G]; WriteReal [rgb.B]; WriteTab []; PutRope ["H, S, L: "]; WriteReal [hsl.H]; WriteReal [hsl.S]; WriteReal [hsl.L]; WriteEOL [] END; ENDLOOP; IF (Terminal.GetColorBitmapState [vt] = displayed) THEN BEGIN ir, ig, ib: Terminal.ColorValue; norm: REAL ~ 1.0 / Float [LAST[Terminal.ColorValue]]; WriteBigLead []; PutRope ["Contents of the ColorMap (r, g, b):"]; WriteEOL []; FOR i: Terminal.ChannelValue IN Terminal.ChannelValue DO [ir, ig, ib] _ Terminal.GetColor [vt, i]; WriteReal [Float[ir] * norm]; WriteReal [Float[ig] * norm]; WriteReal [Float[ib] * norm]; WriteEOL [] ENDLOOP END; TiogaAccess.WriteFile [document, "[]<>Users>Beretta.pa>CD>NectarineTune.tioga"]; TerminalIO.PutRope ["[]<>Users>Beretta.pa>CD>NectarineTune.tioga created.\n"] END; -- FindAllColours <> symbolLook ['l] _ TRUE; symbolLook ['m] _ TRUE; labelLook ['l] _ TRUE; labelLook ['b] _ TRUE; charLook ['l] _ TRUE; Commander.Register [key: "Nectar", proc: FindAllColours, doc: "To tune-up Nectarine"] END.