home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / Fortran.51 / DISK6 / PALETTE.FO$ / PALETTE.bin
Text File  |  1990-09-28  |  4KB  |  154 lines
  1. CC  PALETTE.FOR - Illustrates functions for assigning color values 
  2. CC                to color indices.  Functions include:
  3. CC                remapallpalette    remappalette
  4.  
  5.       INCLUDE  'FGRAPH.FI'
  6.       INCLUDE  'FGRAPH.FD'
  7.  
  8.       INTEGER*2            status2, mode, cells, x, y, xinc, yinc, i
  9.       INTEGER*4            status4, pal(256), iblue, ired, igreen
  10.       INTEGER*4            RGB, tmp, inc
  11.       CHARACTER*3          str1, str2
  12.       RECORD /videoconfig/ vc
  13.  
  14. C
  15. C     Make sure all palette numbers are valid.
  16. C
  17.       DO i = 1, 256
  18.          pal(i) = $BLACK
  19.       END DO
  20. C
  21. C     Loop through each graphics mode that supports palettes.
  22. C
  23.  
  24.       DO mode = $MRES4COLOR, $MRES256COLOR
  25.          IF( mode .EQ. $ERESNOCOLOR ) CYCLE
  26.          IF( setvideomode( mode ) .EQ. 0 ) CYCLE
  27.  
  28. C
  29. C        Get configuration variables for current mode.
  30. C
  31.          CALL getvideoconfig( vc )
  32.          SELECT CASE( vc.numcolors )
  33.  
  34.             CASE( 256 )
  35. C
  36. C              Active bits in this order:
  37. C              ???????? ??bbbbbb ??gggggg ??rrrrrr
  38. C
  39.                cells = 13
  40.                inc   = 12
  41.  
  42.             CASE( 16 )
  43. C
  44. C              If $ERES or $VRES16, active bits in this order:
  45. C              ???????? ??????bb ??????gg ??????rr
  46. C
  47. C              Else in this order:
  48. C              ???????? ??????Bb ??????Gg ??????Rr
  49. C
  50.                cells = 4
  51.                inc   = 32
  52.                IF( (vc.mode .EQ. $ERESCOLOR)  .OR.
  53.      +             (vc.mode .EQ. $VRES16COLOR)) inc = 16
  54.  
  55.             CASE( 4 )
  56. C
  57. C              Active bits in this order:
  58. C              ???????? ??????Bb ??????Gg ??????Rr
  59. C
  60.                cells = 2
  61.                inc   = 32
  62.  
  63.             CASE DEFAULT
  64.                CYCLE
  65.  
  66.          END SELECT
  67.  
  68.          xinc = vc.numxpixels / cells
  69.          yinc = vc.numypixels / cells
  70.  
  71. C
  72. C        Fill palette arrays in BGR order.
  73. C
  74.          i = 1
  75.          DO iblue = 0, 63, inc
  76.             DO igreen = 0, 63, inc
  77.                DO ired = 0, 63, inc
  78.                   pal(i) = RGB( ired, igreen, iblue )
  79. C
  80. C                 Special case: using 6 bits to represent 16 colors
  81. C                 If both bits are on for a color, intensity is set
  82. C                 If one bit is set for a color, the color is on.
  83. C
  84.                   IF( inc .EQ. 32 )
  85.      +                pal(i + 8) = pal(i) .OR. (pal(i) / 2)
  86.                   i = i + 1
  87.                END DO
  88.             END DO
  89.          END DO
  90. C
  91. C        If palettes available, remap all palettes at once.
  92. C        Otherwise, quit.
  93. C
  94.          IF( remapallpalette( pal ) .EQ. 0 ) THEN
  95.             status2 = setvideomode( $DEFAULTMODE )
  96.             STOP 'Palettes not available with this adapter'
  97.          END IF
  98. C
  99. C        Draw colored squares.
  100. C
  101.          i = 0
  102.          DO x = 0, ( xinc * cells ) - 1, xinc
  103.             DO y = 0, ( yinc * cells ) - 1, yinc
  104.                status2 = setcolor( INT4( i ) )
  105.                status2 = rectangle( $GFILLINTERIOR, x, y, x + xinc,
  106.      +                             y + yinc )
  107.                i      = i + 1
  108.             END DO
  109.          END DO
  110.  
  111.          status2 = setcolor( INT4( vc.numcolors / 2 ) )
  112.          WRITE (str1, '(I3)') vc.mode
  113.          WRITE (str2, '(I3)') vc.numcolors
  114.          CALL outtext( 'Mode' // str1 // ' has' //
  115.      +                  str2 // ' colors' )
  116.          READ (*,*)
  117.  
  118. C
  119. C        Change each palette entry separately in GRB order.
  120. C
  121.          i = 0
  122.          DO igreen = 0, 63, inc
  123.             DO ired = 0, 63, inc
  124.                DO iblue = 0, 63, inc
  125.                   tmp    = RGB( ired, igreen, iblue )
  126.                   status4 = remappalette( i, tmp )
  127.                   IF( inc .EQ. 32 )
  128.      +               status4 = remappalette(i + 8, tmp.OR.(tmp / 2))
  129.                   i = i + 1
  130.                END DO
  131.             END DO
  132.          END DO
  133.  
  134. READ (*,*)      ! Wait for ENTER to be pressed
  135.       END DO
  136.  
  137.       status2 = setvideomode( $DEFAULTMODE )
  138.       END
  139.  
  140.  
  141.  
  142. CC  RGB - Function for mixing red, green, and blue color elements.
  143. CC
  144. CC  Params:r,g,b-Valuesforred,green,and blue, respectively
  145. CC
  146. CC  Return:Mixed color value
  147.  
  148.       INTEGER*4 FUNCTION RGB( r, g, b )
  149.       INTEGER*4 r, g, b
  150.       
  151.       RGB = ISHL( ISHL( b, 8 ) .OR. g, 8 ) .OR. r
  152.       RETURN
  153.       END
  154.