home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / gprocs / palettes.icn < prev    next >
Text File  |  2002-01-23  |  9KB  |  406 lines
  1. ############################################################################
  2. #
  3. #    File:     palettes.icn
  4. #
  5. #    Subject:  Procedures for programmer-defined palettes
  6. #
  7. #    Author:   Ralph E. Griswold
  8. #
  9. #    Date:     January 23, 2001
  10. #
  11. ############################################################################
  12. #
  13. #  This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #  These procedures implement programmer-defined palettes.  They overload
  18. #  and build on top of the built-in palette mechanism.
  19. #
  20. ############################################################################
  21. #
  22. #  Data structures:
  23. #
  24. #    Palette_() is a record that holds the information for a
  25. #    programmer-defined palette.  Its fields are:
  26. #
  27. #        name:    the name the palette is known by
  28. #        keys:  the string of the palette characters
  29. #        table:   a table keyed by the palette characters
  30. #             whose corresponding values are the colors
  31. #
  32. #    Color_() is a record that holds the components of an RGB
  33. #    color in separate r, g, and b fields.
  34. #
  35. #    PDB_ is a table whose keys are the names of programmer-
  36. #    defined palettes and whose corresponding values are the
  37. #       palettes.  PDB_ is a global variable and provides the
  38. #    way for programmer-defined palette procedures to access
  39. #    a particular database.  If it is null, a new database is
  40. #    created.
  41. #
  42. #  Procedures:
  43. #
  44. #    BuiltinPalette(name)
  45. #        succeeds if name is the name of a built-in palette but
  46. #        fails otherwise.
  47. #
  48. #    CreatePalette(name, keys, colors)
  49. #        creates a new palette with the given colors and
  50. #        corresponding keys.  The colors used are the given ones.
  51. #
  52. #    InitializePalettes()
  53. #        initializes the built-in palette mechanism; it is called
  54. #        by the first palette procedure that is called.
  55. #
  56. #    Measure(color1, color2) returns the a measure of the distance
  57. #         between color1 and color2 in RGB space.
  58. #
  59. #    NearColor(name, color)
  60. #        returns a color close to color in the palette name.
  61. #
  62. #    PaletteChars(win, palette)
  63. #        returns the palette characters of palette.  It extends
  64. #        the standard version.
  65. #
  66. #    PaletteColor(win, palette, key)
  67. #        returns color in palette for the given key. It extends
  68. #        the standard version.
  69. #
  70. #    PaletteKey(win, palette, color)
  71. #        returns the key in palette closest to the given color.
  72. #
  73. #    RGB(color)
  74. #        parses RGB color and returns a corresponding record.
  75. #
  76. #    makepalette(name, clist)
  77. #        makes a palette from the list of colors, choosing
  78. #        keys automatically.
  79. #
  80. #    palette_colors(palette)
  81. #
  82. #        returns the list of colors in palette.
  83. #
  84. #  Procedures fail in case of errors. This leaves control and error
  85. #  reporting to programs that use this module.  This module is intended
  86. #  to be used by programs that manage the necessary data and supply
  87. #  the table through PDB_.  The problem with this is that there is
  88. #  no way to differentiate errors.  A solution would be to post error
  89. #  messages in a global variable.
  90. #
  91. #  Limitations and problems:
  92. #
  93. #    The names of built-in palettes may not be used for programmer-
  94. #    defined ones.
  95. #
  96. #    PaletteGrays() is not implemented for programmer-defined
  97. #    palettes.  The library version should work for built-in
  98. #    palettes with this module linked.
  99. #
  100. #    Transparency is not yet implemented for DrawImage().
  101. #
  102. #    ReadImage() does not yet support programmer defined palettes.
  103. #
  104. #    Not tested:  Capture(), which may work.
  105. #
  106. #    There is some library code that checks for the names of
  107. #    built-in palettes in an ad-hoc fashion.  It therefore is
  108. #    not advisable to use names for programmer-defined palettes
  109. #    that begin with "c" or "g" followed by a digit.
  110. #
  111. ############################################################################
  112. #
  113. #  Requires:  Version 9 graphics
  114. #
  115. ############################################################################
  116. #
  117. #  Links:  imrutils, lists, sort
  118. #
  119. ############################################################################
  120.  
  121. link imrutils
  122. link lists
  123. link sort
  124.  
  125. global PDB_
  126.  
  127. record Palette_(name, keys, table)
  128. record Color_(r, g, b)
  129.  
  130. #  Check for built-in palette
  131.  
  132. procedure BuiltinPalette(name)            #: check for built-in palette
  133.  
  134.    BuiltinPalette := proc("PaletteChars", 0)
  135.  
  136.    return BuiltinPalette(name)
  137.  
  138. end
  139.  
  140. procedure CreatePalette(name, keys, colors)    #: create palette
  141.    local i, k, t
  142.  
  143.    initial InitializePalettes()
  144.  
  145.    if BuiltinPalette(name) then fail
  146.  
  147.    if *keys ~= *cset(keys) then fail    # duplicate keys
  148.  
  149.    if *keys ~= *colors then fail    # mismatch
  150.  
  151.    t := table()
  152.  
  153.    every i := 1 to *colors do
  154.       t[keys[i]] := ColorValue(colors[i]) | fail
  155.  
  156.    PDB_[name] := Palette_(name, keys, t)
  157.  
  158.    return PDB_[name]
  159.  
  160. end
  161.  
  162. #  Extended version of DrawImage()
  163.  
  164. procedure DrawImage(args[])            #: draw image
  165.    local palette_pixels, palette_lookup, keys, c, i, row, imr
  166.    static draw_image
  167.  
  168.    initial draw_image := proc("DrawImage", 0)
  169.  
  170.    if type(args[1]) ~== "window" then push(args, &window)
  171.  
  172.    imr := imstoimr(args[4]) | return draw_image ! args
  173.  
  174.    if BuiltinPalette(imr.palette) then return draw_image ! args
  175.  
  176.    palette_lookup := (\PDB_[imr.palette]).table | fail
  177.    palette_pixels := copy(palette_lookup)
  178.  
  179.    keys := cset(imr.pixels)
  180.  
  181.    every !palette_pixels := []        # empty lists for coordinates
  182.  
  183.    every c := !keys do {
  184.       i := 0
  185.       imr.pixels ? {
  186.          while row := move(imr.width) do {
  187.             row ? {
  188.                every put(palette_pixels[c], upto(c) - 1, i)
  189.                }
  190.             i +:= 1
  191.             }
  192.          }
  193.       }
  194.  
  195.    every c := !keys do {
  196.       Fg(palette_lookup[c]) | fail        # fails for invalid character
  197.       DrawPoint ! palette_pixels[c]
  198.       }
  199.  
  200.    return
  201.  
  202. end
  203.  
  204. #  Initialize defined palette mechanism
  205.  
  206. procedure InitializePalettes()            #: initialize palettes
  207.  
  208.    /PDB_ := table()
  209.  
  210.    if type(PDB_) ~== "table" then runerr(777)
  211.  
  212.    InitializePalettes := 1        # make this procedure a no-op
  213.  
  214.    return
  215.  
  216. end
  217.  
  218. procedure Measure(s1, s2)            #: measure of RGB distance
  219.    local color1, color2
  220.  
  221.    color1 := RGB(s1)
  222.    color2 := RGB(s2)
  223.  
  224.    return (color1.r - color2.r) ^ 2 + (color1.g - color2.g) ^ 2 +
  225.       (color1.b - color2.b) ^ 2
  226.  
  227. end
  228.  
  229. #  Get color close to specified key
  230.  
  231. procedure NearColor(name, s)            #: close color in palette
  232.    local palette_lookup, k, measure, close_key, color
  233.  
  234.    measure := 3 * (2 ^ 16 - 1) ^ 2    # maximum
  235.  
  236.    color := ColorValue(s) | fail
  237.  
  238.    palette_lookup := (\PDB_[name]).table | fail
  239.  
  240.    every k := key(palette_lookup) do
  241.       if measure >:= Measure(palette_lookup[k], color) then {
  242.         close_key := k
  243.         if measure = 0 then break
  244.         }
  245.  
  246.    return \close_key
  247.  
  248. end
  249.  
  250. #  Extended version of PaletteChars()
  251.  
  252. procedure PaletteChars(args[])            #: characters in palette
  253.    local name
  254.    static palette_chars
  255.  
  256.    initial {
  257.       InitializePalettes()
  258.       palette_chars := proc("PaletteChars", 0)
  259.       }
  260.  
  261.    if type(args[1]) == "window" then get(args)
  262.  
  263.    name := args[1]
  264.  
  265.    if BuiltinPalette(name) then return palette_chars(name)
  266.    else return (\PDB_[name]).keys
  267.  
  268. end
  269.  
  270. #  Extended version of PaletteColor()
  271.  
  272. procedure PaletteColor(args[])            #: color for key in palette
  273.    local palette_lookup, name, s
  274.    static palette_color
  275.  
  276.    initial {
  277.       InitializePalettes()
  278.       palette_color := proc("PaletteColor", 0)
  279.       }
  280.  
  281.    if type(args[1]) == "window" then get(args)
  282.  
  283.    name := args[1]
  284.    s := args[2]
  285.  
  286.    if BuiltinPalette(name) then return palette_color(name, s)
  287.  
  288.    palette_lookup := (\PDB_[name]).table | fail
  289.  
  290.    return \palette_lookup[s]
  291.  
  292. end
  293.  
  294. #  Extended version of PaletteKey()
  295.  
  296. procedure PaletteKey(args[])            #: key for color in palette
  297.    local name, s
  298.    static palette_key
  299.  
  300.    initial {
  301.       InitializePalettes()
  302.       palette_key := proc("PaletteKey", 0)
  303.       }
  304.  
  305.    if type(args[1]) == "window" then get(args)
  306.  
  307.    name := args[1]
  308.    s := args[2]
  309.  
  310.    if BuiltinPalette(name) then return palette_key(name, s)
  311.    else return NearColor(name, s)
  312.  
  313. end
  314.  
  315. procedure RGB(s)                #: convert RGB color to record
  316.    local color
  317.  
  318.    color := Color_()
  319.  
  320.    ColorValue(s) ? {
  321.       color.r := tab(upto(',')) &
  322.       move(1) &
  323.       color.g := tab(upto(',')) &
  324.       move(1) &
  325.       color.b := tab(0)
  326.       } | fail
  327.  
  328.    return color
  329.  
  330. end
  331.  
  332. procedure makepalette(name, clist)        #: make palette automatically
  333.    local keys
  334.    static alphan
  335.  
  336.    initial alphan := &digits || &letters
  337.  
  338.    if *clist = 0 then fail
  339.  
  340.    keys :=
  341.       if *clist < *alphan then alphan
  342.       else &cset
  343.  
  344.    CreatePalette(name, keys[1+:*clist], clist) | fail
  345.  
  346.    return
  347.  
  348. end
  349.  
  350. procedure palette_colors(p)            #: list of palette colors
  351.    local clist
  352.  
  353.    clist := []
  354.  
  355.    every put(clist, PaletteColor(p, !PaletteChars(p)))
  356.  
  357.    return clist
  358.  
  359. end
  360.  
  361. procedure keyseq(palette, colors[])        #: sequence of palette keys
  362.    local chars
  363.  
  364.    chars := PaletteChars(palette)
  365.  
  366.    suspend upto(PaletteKey(palette, !colors), chars)
  367.  
  368. end
  369.  
  370. procedure color_range(color, range)        #: adjust RGB range
  371.    local r, g, b
  372.  
  373.    range := 2 ^ 16 / range
  374.  
  375.    color ? {
  376.       r := tab(upto(','))
  377.       move(1)
  378.       g := tab(upto(','))
  379.       move(1)
  380.       b := tab(0)
  381.       return (r * range) || "," || (g * range) || "," || (b * range)
  382.       }
  383.  
  384. end
  385.  
  386. procedure colorseq(palette)            #: sequence of palette colors
  387.  
  388.    suspend PaletteColor(palette, !PaletteChars(palette))
  389.  
  390. end
  391.  
  392. procedure sort_colors(colors)
  393.  
  394.    return isort(colors, value)
  395.  
  396. end
  397.  
  398. procedure value(s)            #: RGB magnitude
  399.    local color
  400.  
  401.    color := RGB(s)
  402.  
  403.    return color.r ^ 2 + color.g ^ 2 + color.b ^ 2
  404.  
  405. end
  406.