home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l180 / 1.ddi / COLORS.BAS < prev    next >
Encoding:
BASIC Source File  |  1989-02-07  |  8.0 KB  |  245 lines
  1.   ' ************************************************
  2.   ' **  Name:          COLORS                     **
  3.   ' **  Type:          Program                    **
  4.   ' **  Module:        COLORS.BAS                 **
  5.   ' **  Language:      Microsoft QuickBASIC 4.00  **
  6.   ' ************************************************
  7.   '
  8.   ' Provides interactive selection of a color shade.
  9.   '
  10.   ' USAGE:           No command line parameters
  11.   ' REQUIREMENTS:    VGA or MCGA
  12.   '                  MIXED.QLB/.LIB
  13.   '                  Mouse
  14.   ' .MAK FILE:       COLORS.BAS
  15.   '                  BITS.BAS
  16.   '                  MOUSSUBS.BAS
  17.   ' PARAMETERS:      (none)
  18.   ' VARIABLES:       red!            Intensity of red, from 0 to 1
  19.   '                  green!          Intensity of green, from 0 to 1
  20.   '                  blue!           Intensity of blue, from 0 to 1
  21.   '                  mask$           Mouse graphics cursor definition string
  22.   '                  xHot%           Mouse cursor hot spot X location
  23.   '                  yHot%           Mouse cursor hot spot Y location
  24.   '                  cursor$         Mouse cursor binary definition string
  25.   '                  fill%           Color bar height calculation
  26.   '                  x%              Color bar horizontal left edge
  27.   '                  x2%             Color bar horizontal right edge
  28.   '                  y%              Color bar vertical top edge
  29.   '                  y2%             Color bar vertical bottom edge
  30.   '                  leftButton%     State of left mouse button
  31.   '                  rightButton%    State of right mouse button
  32.   '                  xMouse%         Horizontal mouse location
  33.   '                  yMouse%         Vertical mouse location
  34.   '                  clickFlag%      Toggle for left mouse button state
  35.   '                  xM%             Modified mouse horizontal location
  36.   '                  quitFlag%       Signal to end program
  37.   
  38.   
  39.   ' Logical constants
  40.     CONST FALSE = 0
  41.     CONST TRUE = NOT FALSE
  42.   
  43.   ' Constants
  44.     CONST REDPAL = 1
  45.     CONST BLUEPAL = 2
  46.     CONST GREENPAL = 3
  47.     CONST TESTPAL = 4
  48.     CONST WHITEPAL = 5
  49.     CONST BARPAL = 6
  50.     CONST DX = 15
  51.     CONST DY = 150
  52.     CONST RX = 180
  53.     CONST RY = 30
  54.     CONST GX = RX + DX + DX
  55.     CONST GY = RY
  56.     CONST BX = GX + DX + DX
  57.     CONST BY = RY
  58.   
  59.   ' Functions
  60.     DECLARE FUNCTION Shade& (red!, green!, blue!)
  61.   
  62.   ' Subprograms
  63.     DECLARE SUB MouseHide ()
  64.     DECLARE SUB MouseMaskTranslate (mask$, xHot%, yHot%, cursor$)
  65.     DECLARE SUB MouseSetGcursor (cursor$)
  66.     DECLARE SUB MouseShow ()
  67.     DECLARE SUB Cursleft (mask$, xHot%, yHot%)
  68.     DECLARE SUB MouseNow (leftButton%, rightButton%, xMouse%, yMouse%)
  69.   
  70.   ' Set 256 color mode
  71.     SCREEN 13
  72.   
  73.   ' Set first three colors as pure red, green, blue
  74.     PALETTE REDPAL, Shade&(1!, 0!, 0!)
  75.     PALETTE GREENPAL, Shade&(0!, 1!, 0!)
  76.     PALETTE BLUEPAL, Shade&(0!, 0!, 1!)
  77.   
  78.   ' Set a pure white color choice
  79.     PALETTE WHITEPAL, Shade&(1!, 1!, 1!)
  80.   
  81.   ' Set bar background color
  82.     PALETTE BARPAL, Shade&(0!, 0!, 0!)
  83.   
  84.   ' Set background to light gray
  85.     PALETTE 0, Shade&(.4, .4, .4)
  86.   
  87.   ' Start each intensity at midscale
  88.     red! = .5
  89.     green! = .5
  90.     blue! = .5
  91.   
  92.   ' Set starting shade
  93.     PALETTE TESTPAL, Shade&(red!, green!, blue!)
  94.   
  95.   ' Create ellipse of circle to show current shade selected
  96.     CIRCLE (70, 100), 80, TESTPAL, , , 1.4
  97.     PAINT (70, 100), TESTPAL
  98.   
  99.   ' Create the three color bars
  100.     LINE (RX, RY)-(RX + DX, RY + DY), WHITEPAL, B
  101.     LINE (GX, GY)-(GX + DX, GY + DY), WHITEPAL, B
  102.     LINE (BX, BY)-(BX + DX, BY + DY), WHITEPAL, B
  103.   
  104.   ' Mark place to quit by clicking
  105.     LOCATE 25, 1
  106.     PRINT "(X) "; CHR$(27); " Quit";
  107.   
  108.   ' Make the left arrow mouse cursor
  109.     Cursleft mask$, xHot%, yHot%
  110.     MouseMaskTranslate mask$, xHot%, yHot%, cursor$
  111.     MouseSetGcursor cursor$
  112.   
  113.   ' Main loop
  114.     DO
  115.       
  116.       ' Put title and current shade number at top
  117.         LOCATE 1, 1
  118.         PRINT "COLOR CHOOSER"; TAB(22);
  119.         PRINT USING "##########"; Shade&(red!, green!, blue!)
  120.       
  121.       ' Fill in the red color bar
  122.         fill% = red! * (DY - 3) + 1
  123.         x% = RX + 1
  124.         x2% = RX + DX
  125.         y% = RY + 1
  126.         y2% = RY + DY
  127.         LINE (x%, y%)-(x2% - 1, y2% - fill% - 1), BARPAL, BF
  128.         LINE (x%, y2% - fill%)-(x2% - 1, y2% - 1), REDPAL, BF
  129.       
  130.       ' Fill in the green color bar
  131.         fill% = green! * (DY - 3) + 1
  132.         x% = GX + 1
  133.         x2% = GX + DX
  134.         y% = GY + 1
  135.         y2% = GY + DY
  136.         LINE (x%, y%)-(x2% - 1, y2% - fill% - 1), BARPAL, BF
  137.         LINE (x%, y2% - fill%)-(x2% - 1, y2% - 1), GREENPAL, BF
  138.       
  139.       ' Fill in the blue color bar
  140.         fill% = blue! * (DY - 3) + 1
  141.         x% = BX + 1
  142.         x2% = BX + DX
  143.         y% = BY + 1
  144.         y2% = BY + DY
  145.         LINE (x%, y%)-(x2% - 1, y2% - fill% - 1), BARPAL, BF
  146.         LINE (x%, y2% - fill%)-(x2% - 1, y2% - 1), BLUEPAL, BF
  147.       
  148.       ' Change the shade of the ellipse
  149.         PALETTE TESTPAL, Shade&(red!, green!, blue!)
  150.       
  151.       ' Refresh mouse cursor
  152.         MouseShow
  153.       
  154.       ' Wait for fresh mouse left button click
  155.         DO
  156.             MouseNow leftButton%, rightButton%, xMouse%, yMouse%
  157.             IF leftButton% = FALSE THEN
  158.                 clickFlag% = FALSE
  159.             END IF
  160.             IF clickFlag% THEN
  161.                 leftButton% = 0
  162.             END IF
  163.         LOOP UNTIL leftButton%
  164.       
  165.       ' Hide mouse and set parameters
  166.         MouseHide
  167.         clickFlag% = TRUE
  168.         xM% = xMouse% \ 2
  169.       
  170.       ' Is mouse in the "Quit" area?
  171.         IF xMouse% < 45 AND yMouse% > 190 THEN
  172.             quitFlag% = TRUE
  173.         END IF
  174.       
  175.       ' Is mouse at the right height to be in a bar?
  176.         IF yMouse% > RY - 2 AND yMouse% < RY + DY + 2 THEN
  177.           
  178.           ' Is mouse in the red bar?
  179.             IF xM% > RX AND xM% < RX + DX THEN
  180.                 red! = 1! - (yMouse% - RY) / DY
  181.                 IF red! < 0 THEN
  182.                     red! = 0
  183.                 ELSEIF red! > 1 THEN
  184.                     red! = 1
  185.                 END IF
  186.             END IF
  187.           
  188.           ' Is mouse in the green bar?
  189.             IF xM% > GX AND xM% < GX + DX THEN
  190.                 green! = 1! - (yMouse% - RY) / DY
  191.                 IF green! < 0 THEN
  192.                     green! = 0
  193.                 ELSEIF green! > 1 THEN
  194.                     green! = 1
  195.                 END IF
  196.             END IF
  197.           
  198.           ' Is mouse in the blue bar?
  199.             IF xM% > BX AND xM% < BX + DX THEN
  200.                 blue! = 1! - (yMouse% - RY) / DY
  201.                 IF blue! < 0 THEN
  202.                     blue! = 0
  203.                 ELSEIF blue! > 1 THEN
  204.                     blue! = 1
  205.                 END IF
  206.             END IF
  207.           
  208.         END IF
  209.       
  210.     LOOP UNTIL quitFlag%
  211.   
  212.     SCREEN 0
  213.     WIDTH 80
  214.     CLS
  215.     END
  216.  
  217.   ' ************************************************
  218.   ' **  Name:          Shade&                     **
  219.   ' **  Type:          Function                   **
  220.   ' **  Module:        COLORS.BAS                 **
  221.   ' **  Language:      Microsoft QuickBASIC 4.00  **
  222.   ' ************************************************
  223.   '
  224.   ' Returns the long integer color number given red,
  225.   ' green, and blue intensity numbers in the range
  226.   ' 0 to 1.
  227.   '
  228.   ' EXAMPLE OF USE:  PALETTE 1, Shade&(red!, green!, blue!)
  229.   ' PARAMETERS:      red!       Intensity of red, from 0 through 1
  230.   '                  green!     Intensity of green, from 0 through 1
  231.   '                  blue!      Intensity of blue, from 0 through 1
  232.   ' VARIABLES:       r&         Red amount
  233.   '                  g&         Green amount
  234.   '                  b&         Blue amount
  235.   ' MODULE LEVEL
  236.   '   DECLARATIONS:  DECLARE FUNCTION Shade& (red!, green!, blue!)
  237.   '
  238.     FUNCTION Shade& (red!, green!, blue!) STATIC
  239.         r& = red! * 63!
  240.         g& = green! * 63!
  241.         b& = blue! * 63!
  242.         Shade& = r& + g& * 256& + b& * 65536
  243.     END FUNCTION
  244.  
  245.