Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

Hex color degrader

by Kage (Scribe)
on Oct 12, 2002 at 22:52 UTC ( [id://204824]=CUFP: print w/replies, xml ) Need Help??

Method to take a Hex color value, such as FF9944, turn it to Decimal, chop down the color by X, and return the new color in Hex, as seen in my Scratchpad.
sub downhex { # Coded by: Kage (Kage@DBXML.com) http://ss.dbmxl.com # Copyright (C) 2002-2005 Kage, All Rights Reserved. my ($hexcolor, $degrade) = @_; my (@rgbarray, $digitcounter, $coltemp, $rgblowcount, $collabel, $pac +kout, $coltemp2, $hexvalue); $hexcolor =~ s/\#//; for ($digitcounter=0; $digitcounter<3; $digitcounter++) { $coltemp = substr($hexcolor, 2*$digitcounter, 2); $rgbarray[$digitcounter] = (16 * hex(substr($coltemp, 0, 1)) + hex(s +ubstr($coltemp, 1, 1))); } for ($rgblowcount=0; $rgblowcount<3; $rgblowcount++) { if ($rgbarray[$rgblowcount] >= $degrade) { $rgbarray[$rgblowcount] = ($rgbarray[$rgblowcount] - $degrade); } } foreach $collabel (@rgbarray) { if (($collabel >= 0) && ($collabel <= 255)) { $packout = pack "c", $collabel; $collabel = unpack "H2", $packout; if (length($collabel) < 2) { $collabel = "0".$collabel; } $coltemp2 .= $collabel; } else { $coltemp2 = ""; break; # Optional, though it won't work in Strict } } if (length($coltemp2) == 6) { $hexvalue = "#".$coltemp2; } return uc($hexvalue); }

Replies are listed 'Best First'.
Re: Hex color degrader
by Aristotle (Chancellor) on Oct 13, 2002 at 11:01 UTC
    The really correct way to do this is to subtract the given value from the largest cofficient, then multiply the smaller cofficients by the quotient of its difference. This way, all coefficients are decreased proportionally, so that unlike with BrowserUK's method the hue never changes, only the luminance. (Actually, it's not 100% correct either, but very close.)
    sub darken_hexrgb { my ($hexrgb, $darken) = @_; my @rgb = map hex, unpack "A2"x3, $hexrgb; my $max = (sort {$a <=> $b} @rgb)[-1]; return "000000" if $max <= $darken; my $fact = ($max - $darken) / $max; return sprintf "%02X"x3, map { int($_ * $fact) } @rgb }

    That's what it looks like:

    darken_hexrgb("FF9944", 8) = F79441
    darken_hexrgb("FF9944", 16) = EF8F3F
    darken_hexrgb("FF9944", 32) = DF853B
    darken_hexrgb("FF9944", 48) = CF7C37
    darken_hexrgb("FF9944", 64) = BF7232
    darken_hexrgb("FF9944", 80) = AF692E
    darken_hexrgb("FF9944", 96) = 9F5F2A
    darken_hexrgb("FF9944", 112) = 8F5526
    darken_hexrgb("FF9944", 128) = 7F4C21
    darken_hexrgb("FF9944", 160) = 5F3919
    darken_hexrgb("FF9944", 176) = 4F2F15
    darken_hexrgb("FF9944", 192) = 3F2510
    darken_hexrgb("FF9944", 208) = 2F1C0C
    darken_hexrgb("FF9944", 224) = 1F1208

    (Layout shamelessly stolen from BrowserUK.)

    Makeshifts last the longest.

      Agreed. That makes perfect sense. However, why not take it one step further and make the function darken or lighten as required.

      #! perl -sw use strict; local $\=$/; sub Dlighken { return sprintf '%02x'x3, map{ ($_ *= 1+$_[1]) > 0xff ? 0xff : $_ } map hex, unpack 'A2'x3, $_[0]; } my @colors = qw/800000 808000 008000 008080 000080 808080 c0c0c0/; print '<table>'; print '<tr><td>&nbsp;</td>', map{ '<th>'.$_.'</th>' } @colors, '</tr>'; for my $scale ( -5 .. +5 ) { print '<tr><td>'.($scale/10).'</td>'; print '<td bgcolor="#', $_, '">', $_, '</td>' for map{ Dlighken($_, $scale/10) } @colors; print '</tr>'; } print '</table>'; __END__

      renders as
       800000808000008000008080000080808080c0c0c0
      -0.5 400000 404000 004000 004040 000040 404040 606060
      -0.4 4c0000 4c4c00 004c00 004c4c 00004c 4c4c4c 737373
      -0.3 590000 595900 005900 005959 000059 595959 868686
      -0.2 660000 666600 006600 006666 000066 666666 999999
      -0.1 730000 737300 007300 007373 000073 737373 acacac
      0 800000 808000 008000 008080 000080 808080 c0c0c0
      0.1 8c0000 8c8c00 008c00 008c8c 00008c 8c8c8c d3d3d3
      0.2 990000 999900 009900 009999 000099 999999 e6e6e6
      0.3 a60000 a6a600 00a600 00a6a6 0000a6 a6a6a6 f9f9f9
      0.4 b30000 b3b300 00b300 00b3b3 0000b3 b3b3b3 ffffff
      0.5 c00000 c0c000 00c000 00c0c0 0000c0 c0c0c0 ffffff


      Cor! Like yer ring! ... HALO dammit! ... 'Ave it yer way! Hal-lo, Mister la-de-da. ... Like yer ring!
        Not a bad point, but I'd stick to having a brightness value passed, not a scaling factor. It's a bit easier to have a rough idea of the outcome that way IMO.
        sub add_to_hexrgb { my @rgb = map hex, unpack "A2"x3, $_[0]; my $max = (sort {$a <=> $b} @rgb)[-1]; my $smax = $max + $_[1]; return $smax < 0 ? "000000" : $smax > 255 ? "FFFFFF" : do { my $fact = ($max + $sumd) / $max; sprintf "%02X"x3, map { int($_ * $fact) } @rgb }; }

        Makeshifts last the longest.

Re: Hex color degrader
by BrowserUk (Patriarch) on Oct 13, 2002 at 04:54 UTC

    It struck me that the way you have implemented your degrade, if one of the rgb value is less than the value by which you are degrading $rgbarray[$rgblowcount] >= $degrade;, it is left untouched. This seems wrong to me.

    Say you had the rgb value
    #ff7fff
    a bright purplish pink and you degrade it by 128 (0x80) then using your algorithm it becomes
    #7f7f7f
    a mid-grey.

    Wouldn't it be better to degrade all of the triplet evenly until they reach zero thereby maintaining the relative proportions of the three colours as long as possible?

    Using my example above,
    #ff7fff
    degraded by 128 becomes
    #7f007f
    a darker purple colour.

    To that end, I offer...

    #! perl -sw use strict; sub min{ $_[0]<$_[1] ? $_[0] : $_[1] } sub degrade{ my ($rgb, $degr) = (hex(shift), pop); $rgb -= min( $rgb&(0xff<<$_), $degr<<$_ ) for (0,8,16); sprintf '%06x', $rgb; } my $rgb = "FF9944"; printf 'Degrading %6s by %3d gives %6s%s', $rgb, $_, degrade( $rgb, $_ +), $/ for (0x01, 0x0f, 0x10, 0x44, 0x80, 0xcc, 0xee, 0xf0); __END__ C:\test>204824
    Degrading FF9944 by    1 gives fe9843
    Degrading FF9944 by   15 gives f08a35
    Degrading FF9944 by   16 gives ef8934
    Degrading FF9944 by   68 gives bb5500
    Degrading FF9944 by 128 gives 7f1900
    Degrading FF9944 by 204 gives 330000
    Degrading FF9944 by 238 gives 110000
    Degrading FF9944 by 240 gives 0f0000

    Cor! Like yer ring! ... HALO dammit! ... 'Ave it yer way! Hal-lo, Mister la-de-da. ... Like yer ring!
•Re: Hex color degrader
by merlyn (Sage) on Oct 12, 2002 at 23:20 UTC
    Far too much work.
    print hexdegrade("FF9944", 3); sub hexdegrade { my $hex = shift; my $degrade = shift; my $temp = pack "H*", $hex; for (0..length($temp)-1) { for (vec($temp, $_, 8)) { $_ -= $degrade if $_ >= $degrade; } } return unpack "H*", $temp; }

    -- Randal L. Schwartz, Perl hacker

Re: Hex color degrader
by Kage (Scribe) on Oct 15, 2002 at 22:05 UTC
    Oh shoot me down, why don't ye. :^P Oh well, it isn't horrible work for a sort of 2 AM work.. Though I do see my mistake with leaving values less than the degrader untouched. I did this as a quick route-around due to the fact that it would return #000000 alot of times if the degrader was more than the value. Oh well.
    Oh poo.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://204824]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others meditating upon the Monastery: (6)
As of 2024-03-28 13:15 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found