C**********************************************************************
C
C	HLS.FOR -- COLOR
C	THIS ROUTINE CHANGES THE COLOR PARAMETERS ON VT241 TERMINALS
C	IT WILL PROBABLY CHANGE GRAYTONES ON VT240 TERMINALS
C
C	Developed by B. Thomson --  LAST UPDATE 17-SEP-1986 17:50:56
C
C**********************************************************************
	BYTE CURSOR,UP,DOWN,LEFT,RIGHT
	INTEGER*2	COLUMN,LINE
	DIMENSION IROW(14),ICOL(14),LENGTH(14),ITEMATRIB(4)	
	CHARACTER*(38) DATA(14)
	CHARACTER*(31) PROMPT(15)
C--------These are used to store HUE, LIGHTNESS & SATURATION values
C	 to be sent to the terminal as the user picks colors
	CHARACTER*(4) H(64)
	CHARACTER*(3) L(64)
	CHARACTER*(4) S(64)
C--------These are used to store HUE, LIGHTNESS & SATURATION values
C	 to be written to sys$login:color.lis
	CHARACTER*(4) HS(4)
	CHARACTER*(3) LS(4)
	CHARACTER*(4) SS(4)

	CHARACTER*(18) NAME(64)
	CHARACTER*(1) RETURN
	CHARACTER BLINE*50,ANS*1,YES*1,NO*1,LYES*1,LNO*1,ESC*1
	PARAMETER ( YES='Y',NO='N',LYES='y',LNO='n')
	DATA CR/13/,UP/65/,DOWN/66/,LEFT/68/,RIGHT/67/,ESC/27/
	DATA RETURN/13/
	DATA BLINE/'                                                  '/
	DATA PROMPT(1)  /'    This routine allows you to'/
	DATA PROMPT(2)  /'set the colors on your VT241  '/
	DATA PROMPT(3)  /'any way you like them. All the'/
	DATA PROMPT(4)  /'enhanced modes are used here  '/
	DATA PROMPT(5)  /'to display thier effect. Pick '/
	DATA PROMPT(6)  /'an item to modify, then use   '/
	DATA PROMPT(7)  /'the arrow keys.  RETURN lets  '/
	DATA PROMPT(8)  /'you pick a new item or exit.  '/
	DATA PROMPT(9)  /'    PLEASE USE UPPERCASE      '/
	DATA PROMPT(10) /'RIGHT-ARROW changes Saturation'/
	DATA PROMPT(11) /' LEFT-ARROW changes Lightness '/
	DATA PROMPT(12) /'UP or DOWN-ARROW changes color'/
	DATA PROMPT(13) /'      This routine uses       '/
	DATA PROMPT(14) /'        the HLS color         '/
	DATA PROMPT(15) /'    specification  system     '/
	DATA NAME(1)  /'AQUAMARINE        '/
	DATA NAME(2)  /'AQUAMARINE, MEDIUM'/
	DATA NAME(3)  /'BLACK             '/
	DATA NAME(4)  /'BLUE              '/
	DATA NAME(5)  /'BLUE, CADET       '/
	DATA NAME(6)  /'BLUE,CORNFLOWER   '/
	DATA NAME(7)  /'BLUE, DARK SLATE  '/
	DATA NAME(8)  /'BLUE, LIGHT       '/
	DATA NAME(9)  /'BLUE, LIGHT STEEL '/
	DATA NAME(10) /'BLUE, MEDIUM      '/
	DATA NAME(11) /'BLUE, MEDIUM SLATE'/
	DATA NAME(12) /'BLUE, MIDNIGHT    '/
        DATA NAME(13) /'BLUE, NAVY        '/
        DATA NAME(14) /'BLUE, SKY         '/
        DATA NAME(15) /'BLUE, SLATE       '/
        DATA NAME(16) /'BLUE, STEEL       '/
        DATA NAME(17) /'CORAL             '/
        DATA NAME(18) /'CYAN              '/
        DATA NAME(19) /'FIREBRICK         '/
        DATA NAME(20) /'GOLD              '/
        DATA NAME(21) /'GOLDENROD         '/
        DATA NAME(22) /'GOLDENROD, MEDIUM '/
        DATA NAME(23) /'GREEN             '/
        DATA NAME(24) /'GREEN, DARK       '/
        DATA NAME(25) /'GREEN, DARK OLIVE '/
        DATA NAME(26) /'GREEN, FOREST     '/
        DATA NAME(27) /'GREEN, LIME       '/
        DATA NAME(28) /'GREEN,MED. FOREST '/
        DATA NAME(29) /'GREEN, MEDIUM SEA '/
        DATA NAME(30) /'GREEN, MED. SPRING'/
        DATA NAME(31) /'GREEN, PALE       '/
        DATA NAME(32) /'GREEN, SEA        '/
        DATA NAME(33) /'GREEN, SPRING     '/
        DATA NAME(34) /'GREEN, YELLOW     '/
        DATA NAME(35) /'GRAY, DARK SLATE  '/
        DATA NAME(36) /'GRAY, DIM         '/
        DATA NAME(37) /'GRAY, LIGHT       '/
        DATA NAME(38) /'KHAKI             '/
        DATA NAME(39) /'MAGENTA           '/
        DATA NAME(40) /'MAROON            '/
        DATA NAME(41) /'ORANGE            '/
        DATA NAME(42) /'ORCHID            '/
        DATA NAME(43) /'ORCHID, DARK      '/
        DATA NAME(44) /'ORCHID, MEDIUM    '/
        DATA NAME(45) /'PINK              '/
        DATA NAME(46) /'PLUM              '/
        DATA NAME(47) /'RED               '/
        DATA NAME(48) /'RED,INDIAN        '/
        DATA NAME(49) /'RED, MEDIUM VIOLET'/
        DATA NAME(50) /'RED, ORANGE       '/
        DATA NAME(51) /'RED, VIOLET       '/
        DATA NAME(52) /'SALMON            '/
        DATA NAME(53) /'SIENNA            '/
        DATA NAME(54) /'TAN               '/
        DATA NAME(55) /'THISTLE           '/
        DATA NAME(56) /'TURQUOISE         '/
        DATA NAME(57) /'TURQUOISE, DARK   '/
        DATA NAME(58) /'TURQUOISE, MEDIUM '/
        DATA NAME(59) /'VIOLET            '/
        DATA NAME(60) /'VIOLET, BLUE      '/
        DATA NAME(61) /'WHEAT             '/
        DATA NAME(62) /'WHITE             '/
        DATA NAME(63) /'YELLOW            '/
        DATA NAME(64) /'YELLOW, GREEN     '/
	DATA H(1),L(1),S(1)  /'H260','L65','S060'/
	DATA H(2),L(2),S(2)  /'H280','L50','S060'/
	DATA H(3),L(3),S(3)  /'H000','L00','S000'/
	DATA H(4),L(4),S(4)  /'H000','L50','S100'/
	DATA H(5),L(5),S(5)  /'H300','L50','S025'/
	DATA H(6),L(6),S(6)  /'H000','L35','S025'/
	DATA H(7),L(7),S(7)  /'H040','L35','S060'/
	DATA H(8),L(8),S(8)  /'H300','L80','S025'/
	DATA H(9),L(9),S(9)  /'H000','L65','S025'/
	DATA H(10),L(10),S(10) /'H000','L50','S060'/
	DATA H(11),L(11),S(11) /'H030','L50','S100'/
	DATA H(12),L(12),S(12) /'H000','L25','S025'/
        DATA H(13),L(13),S(13) /'H000','L35','S060'/
        DATA H(14),L(14),S(14) /'H320','L50','S060'/
        DATA H(15),L(15),S(15) /'H330','L50','S100'/
        DATA H(16),L(16),S(16) /'H320','L35','S060'/
        DATA H(17),L(17),S(17) /'H150','L50','S100'/
        DATA H(18),L(18),S(18) /'H300','L50','S100'/
        DATA H(19),L(19),S(19) /'H120','L35','S060'/
        DATA H(20),L(20),S(20) /'H150','L50','S060'/
        DATA H(21),L(21),S(21) /'H180','L65','S060'/
        DATA H(22),L(22),S(22) /'H180','L80','S060'/
        DATA H(23),L(23),S(23) /'H240','L50','S100'/
        DATA H(24),L(24),S(24) /'H240','L25','S025'/
        DATA H(25),L(25),S(25) /'H180','L25','S025'/
        DATA H(26),L(26),S(26) /'H240','L35','S060'/
        DATA H(27),L(27),S(27) /'H240','L50','S060'/
        DATA H(28),L(28),S(28) /'H200','L35','S060'/
        DATA H(29),L(29),S(29) /'H240','L35','S025'/
        DATA H(30),L(30),S(30) /'H210','L50','S100'/
        DATA H(31),L(31),S(31) /'H240','L65','S025'/
        DATA H(32),L(32),S(32) /'H280','L35','S060'/
        DATA H(33),L(33),S(33) /'H270','L50','S100'/
        DATA H(34),L(34),S(34) /'H200','L50','S060'/
        DATA H(35),L(35),S(35) /'H300','L25','S025'/
        DATA H(36),L(36),S(36) /'H000','L33','S000'/
        DATA H(37),L(37),S(37) /'H000','L66','S000'/
        DATA H(38),L(38),S(38) /'H180','L50','S025'/
        DATA H(39),L(39),S(39) /'H060','L50','S100'/
        DATA H(40),L(40),S(40) /'H080','L35','S060'/
        DATA H(41),L(41),S(41) /'H120','L50','S060'/
        DATA H(42),L(42),S(42) /'H060','L65','S060'/
        DATA H(43),L(43),S(43) /'H040','L50','S060'/
        DATA H(44),L(44),S(44) /'H020','L65','S060'/
        DATA H(45),L(45),S(45) /'H120','L65','S025'/
        DATA H(46),L(46),S(46) /'H060','L80','S060'/
        DATA H(47),L(47),S(47) /'H120','L50','S100'/
        DATA H(48),L(48),S(48) /'H120','L25','S025'/
        DATA H(49),L(49),S(49) /'H100','L65','S060'/
        DATA H(50),L(50),S(50) /'H090','L50','S100'/
        DATA H(51),L(51),S(51) /'H080','L50','S060'/
        DATA H(52),L(52),S(52) /'H120','L35','S025'/
        DATA H(53),L(53),S(53) /'H160','L35','S060'/
        DATA H(54),L(54),S(54) /'H140','L65','S060'/
        DATA H(55),L(55),S(55) /'H060','L80','S025'/
        DATA H(56),L(56),S(56) /'H300','L80','S060'/
        DATA H(57),L(57),S(57) /'H340','L65','S060'/
        DATA H(58),L(58),S(58) /'H300','L65','S060'/
        DATA H(59),L(59),S(59) /'H060','L25','S025'/
        DATA H(60),L(60),S(60) /'H060','L50','S025'/
        DATA H(61),L(61),S(61) /'H180','L80','S025'/
        DATA H(62),L(62),S(62) /'H000','L99','S000'/
        DATA H(63),L(63),S(63) /'H180','L50','S100'/
        DATA H(64),L(64),S(64) /'H220','L65','S060'/
	DATA ITEMATRIB /0,0,0,0/
	DATA IROW  /05,06,06,07,08,09,09,09,11,12,13,14,15,16/
	DATA ICOL  /20,20,36,20,20,20,47,50,20,20,20,20,20,20/
	DATA LENGTH/30,15,20,30,30,25,02,10,25,25,38,38,38,38/
	INTEGER*2 IOSB(4),ICHAN,ICHAR
	INTEGER*4 TERMINATOR(2),STATUS,SYS$ASSIGN,SYS$QIOW
	INCLUDE'($IODEF)'
	DATA TERMINATOR/0,0/
	DATA ICHAN/1/
C**********************************************************************
C---------ASSIGN A CHANNEL TO THE TERMINAL.
	STATUS=SYS$ASSIGN('TT:',ICHAN,,)
C---------WAS THE ASSIGNMENT SUCCESSFUL?
	IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))
C---------Draw Outline
50	STATUS=LIB$ERASE_PAGE(1,1)
	STATUS=LIB$PUT_SCREEN(BLINE,1,15,2)
	STATUS=LIB$PUT_SCREEN(BLINE,2,15,2)
	STATUS=LIB$PUT_SCREEN(BLINE,3,15,2)
	DO 52 I=4,20
	STATUS=LIB$PUT_SCREEN('   ',I,15,2)
52	STATUS=LIB$PUT_SCREEN('   ',I,62,2)
	STATUS=LIB$PUT_SCREEN(BLINE,19,15,2)
	STATUS=LIB$PUT_SCREEN(BLINE,20,15,2)
C---------Display titles
	STATUS=LIB$PUT_SCREEN('VT@$! COLOR CHANGE',2,30,2)
	STATUS=LIB$PUT_SCREEN('CURRENT ITEM',4,66,8)
	STATUS=LIB$PUT_SCREEN('EXIT'  ,16,70,0)
	STATUS=LIB$PUT_SCREEN('Currently',10,2,0)
	STATUS=LIB$PUT_SCREEN('Modifing ',11,2,0)
C---------Write in explainations
	LINE=4
	IATT=1
	COLUMN=25
C
56	LINE=LINE+1
	IATT=IATT+1
	STATUS = LIB$PUT_SCREEN(PROMPT(IATT),LINE,COLUMN,IATT)
	IF (IATT.NE.15) GOTO 56
C---------Load in starting colors
	ISUB=3
 	TYPE 291,ESC,0,H(ISUB),L(ISUB),S(ISUB),ESC
	HS(1)=H(ISUB)
	LS(1)=L(ISUB)
	SS(1)=S(ISUB)

	ISUB=39
 	TYPE 291,ESC,1,H(ISUB),L(ISUB),S(ISUB),ESC
	HS(2)=H(ISUB)
	LS(2)=L(ISUB)
	SS(2)=S(ISUB)

	ISUB=21
 	TYPE 291,ESC,2,H(ISUB),L(ISUB),S(ISUB),ESC
	HS(3)=H(ISUB)
	LS(3)=L(ISUB)
	SS(3)=S(ISUB)

	ISUB=26
 	TYPE 291,ESC,3,H(ISUB),L(ISUB),S(ISUB),ESC
	HS(4)=H(ISUB)
	LS(4)=L(ISUB)
	SS(4)=S(ISUB)
C---------Start of main loop
60	ITEM=0
61	ITEMATRIB(0)=0
	ITEMATRIB(2)=0
	ITEMATRIB(3)=0
	ITEMATRIB(4)=0
C---------Hi-light the selected ITEM
	IF (ITEM.GT.0) ITEMATRIB(ITEM)=1
	STATUS=LIB$PUT_SCREEN('Background' , 8,70,ITEMATRIB(1))
	STATUS=LIB$PUT_SCREEN('1st plane'  ,10,70,ITEMATRIB(2))
	STATUS=LIB$PUT_SCREEN('2nd plane'  ,12,70,ITEMATRIB(3))
	STATUS=LIB$PUT_SCREEN('Combination',14,70,ITEMATRIB(4))
	GO TO (100,200,200,200),ITEM
C---------Get ITEM
	STATUS=LIB$ERASE_LINE(23,1)
62	STATUS=LIB$PUT_SCREEN
     &('What item do you want to change? (B,1,2,C or E)',23,5,1)
	STATUS=LIB$GET_SCREEN(ANS,,INLENGTH,0)
	STATUS=LIB$ERASE_LINE(23,5)
	IF (ANS.EQ. 'E') GO TO 900
	IF (ANS.EQ. 'B') THEN
	ITEM=1 
	ELSE IF (ANS.EQ. '1') THEN
	ITEM=2
	ELSE IF (ANS.EQ. '2') THEN
	ITEM=3 
	ELSE IF (ANS.EQ. 'C') THEN
	ITEM=4 
	ELSE
	STATUS=LIB$PUT_SCREEN('B,1,2,C or E only!!',23,60,15)
	END IF
	GO TO 61
100	continue
C**********************************************************************
200	STATUS=LIB$SET_CURSOR(23,40)
C---------ISSUE THE QIOW FOR ONE CHARACTOR.
206	STATUS=SYS$QIOW(,%VAL(ICHAN),
     &%VAL(IO$_READVBLK.OR.IO$M_NOECHO),
     &IOSB,,,ICHAR,%VAL(1),,TERMINATOR,,)
C---------DID IT POST CORRECTLY?
	IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))
C---------WAS THE QIO SUCCESSFUL?
	IF (.NOT. IOSB(1)) CALL LIB$STOP(%VAL(STATUS))
	CURSOR=ICHAR
C---------Did I capture the cursor string?
	IDIRECT =0
	IF (CURSOR.EQ. CR   ) IDIRECT =1
	IF (CURSOR.EQ. UP   ) IDIRECT =2
	IF (CURSOR.EQ. DOWN ) IDIRECT =3
	IF (CURSOR.EQ. LEFT ) IDIRECT =4
	IF (CURSOR.EQ. RIGHT) IDIRECT =5
	IF (IDIRECT.EQ.0 ) GOTO 206
C	TYPE 210, CURSOR,IDIRECT
C210	FORMAT(10X,'===>',1A1,'<===>',I2,'<===')
	GO TO (60,260,290,270,280),IDIRECT
C---------THIS SECTION IS NOT USED ANY LONGER
C---------Change Color hue of the item selected
C260	IHUE=IHUE+20
C	STATUS=LIB$PUT_SCREEN('Color Hue =    ',12,2,1)
C 	TYPE 250,ESC,ITEM-1,IHUE,ESC
C250	FORMAT('+',1A1'P0pS(M',I1,'(H',I3,'))',
C     &1A1,'/')
C	STATUS=LIB$PUT_SCREEN(IHUE,12,13,1)
C	GO TO 206
C---------Change Color of the item selected
260	IF (ISUB.EQ.1) ISUB=65
	ISUB=ISUB-1
	STATUS=LIB$PUT_SCREEN(NAME(ISUB),12,2,1)
 	TYPE 291,ESC,ITEM-1,H(ISUB),L(ISUB),S(ISUB),ESC
	HS(ITEM)=H(ISUB)
	LS(ITEM)=L(ISUB)
	SS(ITEM)=S(ISUB)
	GO TO 206
C---------Change Lightness of the item selected
270	IF (ILIGHT.GT.90) ILIGHT=0
	ILIGHT=ILIGHT+10
	STATUS=LIB$PUT_SCREEN('Lightness =    ',12,2,1)
 	TYPE 271,ESC,ITEM-1,ILIGHT,ESC
271	FORMAT('+',1A1'P0pS(M',I1,'(L',I3,'))',
     &1A1,'/')
C	STATUS=LIB$PUT_SCREEN(ILIGHT,12,13,1)
	GO TO 206
C---------Change Saturation of the item selected
280	IF (ISAT.GT.90) ISAT=0
	ISAT=ISAT+10
	STATUS=LIB$PUT_SCREEN('Saturation=    ',12,2,1)
 	TYPE 281,ESC,ITEM-1,H(ISUB),L(ISUB),ISAT,ESC
281	FORMAT('+',1A1'P0pS(M',I1,'(',A4,A3,'S',I3,'))',
     &1A1,'/')
c	STATUS=LIB$PUT_SCREEN(ISAT,12,13,1)
	GO TO 206
C---------Change Color of the item selected
290	IF (ISUB.GT.64) ISUB=0
	ISUB=ISUB+1
	STATUS=LIB$PUT_SCREEN(NAME(ISUB),12,2,1)
 	TYPE 291,ESC,ITEM-1,H(ISUB),L(ISUB),S(ISUB),ESC
291	FORMAT('+',1A1'P0pS(M',I1,'(',A4,A3,A4,'))',
     &1A1,'/')
	HS(ITEM)=H(ISUB)
	LS(ITEM)=L(ISUB)
	SS(ITEM)=S(ISUB)
	GO TO 206
C**********************************************************************
C         End of Job
C**********************************************************************
900	STATUS=LIB$ERASE_LINE(23,1)
910	STATUS=LIB$PUT_SCREEN
     &('Do you want to save this color combination? (Y or RETURN)'
     &,23,5,1)
	STATUS=LIB$GET_SCREEN(ANS,,INLENGTH,0)
	STATUS=LIB$ERASE_LINE(23,5)
	IF (ANS.NE. 'Y') GO TO 999
        OPEN (UNIT=4,NAME='SYS$LOGIN:COLOR.LIS',STATUS='NEW')
C       WRITE (4,271)ESC,ITEM-1,ILIGHT,ESC
C 	WRITE (4,281)ESC,ITEM-1,H(ISUB),L(ISUB),ISAT,ESC
 	WRITE (4,921)ESC,
     &0,HS(1),LS(1),SS(1),
     &1,HS(2),LS(2),SS(2),
     &2,HS(3),LS(3),SS(3),
     &3,HS(4),LS(4),SS(4),
     &ESC
921	FORMAT('+',1A1'P0pS(M',I1,'(',A4,A3,A4,'))',
     &'S(M',I1,'(',A4,A3,A4,'))',
     &'S(M',I1,'(',A4,A3,A4,'))',
     &'S(M',I1,'(',A4,A3,A4,'))',
     &1A1,'/')
 	WRITE (4,930) RETURN
930     FORMAT(' ===========================================',A1,
     &'   VT241 special color definitions have been performed')
        CLOSE (UNIT=4)
999	STATUS=LIB$ERASE_PAGE(1,1)
	END
