' *****************
' *** COLOR.LST ***
' *****************
'
DEFWRD "a-z"
'
> PROCEDURE new.low.colors
  ' *** new palette (Low resolution)
  ' *** please,please,please, restore original palette before exiting program
  LOCAL n,r,g,b,col$
  RESTORE low.new.col.data
  FOR n=0 TO 15
    READ col$
    r=VAL(LEFT$(col$))
    g=VAL(MID$(col$,2,1))
    b=VAL(RIGHT$(col$))
    VSETCOLOR n,r,g,b
  NEXT n
  '
  ' *** rgb-values of new palette (switch to Overwrite-mode of editor)
  low.new.col.data:
  DATA 777,000,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX,XXX
RETURN
' **********
'
> PROCEDURE new.med.colors
  ' *** new palette (Medium resolution)
  ' *** please,please,please, restore original palette before exiting program
  LOCAL n,r,g,b,col$
  RESTORE med.new.col.data
  FOR n=0 TO 3
    READ col$
    r=VAL(LEFT$(col$))
    g=VAL(MID$(col$,2,1))
    b=VAL(RIGHT$(col$))
    VSETCOLOR n,r,g,b
  NEXT n
  '
  ' *** rgb-values of new palette (switch to Overwrite-mode of editor)
  med.new.col.data:
  DATA 777,000,XXX,XXX
RETURN
' **********
'
> PROCEDURE save.palette
  ' *** save current palette in integer-array
  ' *** global :   OLD.PALETTE%()
  LOCAL i
  ERASE old.palette%()
  DIM old.palette%(15)
  FOR i=0 TO 15
    old.palette%(i)=XBIOS(7,i,-1)
  NEXT i
RETURN
' ***
> PROCEDURE restore.palette
  ' *** restore original palette
  LOCAL i
  FOR i=0 TO 15
    VOID XBIOS(7,i,old.palette%(i))
  NEXT i
RETURN
' **********
'
> PROCEDURE make.palette.string(VAR pal$)
  ' *** save current palette in (Degas-compatible) string
  LOCAL n
  pal$=""
  FOR n=0 TO 15
    pal$=pal$+MKI$(XBIOS(7,n,-1))
  NEXT n
RETURN
' **********
'
> PROCEDURE change.palette(pal.string$)
  ' *** change palette with (Degas-compatible) string
  VOID XBIOS(6,L:VARPTR(pal.string$))
RETURN
' **********
'
> PROCEDURE rgb.value(index,VAR rgb$)
  ' *** returns RGB-string of color-index
  ' *** uses Standard Array color.index()
  LOCAL col%
  col%=XBIOS(7,color.index(index),-1)
  rgb$=RIGHT$(HEX$(col%),3)
RETURN
' **********
'
> PROCEDURE screen(txt.col$,back.col$)
  ' *** change color of all PRINTed text and color of background (TOS-screen !)
  ' *** use RGB-strings (e.g. "777" for white)
  ' *** uses Standard Array Color.index
  ' *** saves old colors in global variables
  ' *** global :  OLD.TEXT.COL$  OLD.BACK.COL$
  old.text.col$=RIGHT$(HEX$(XBIOS(7,color.index(1),-1)),3)
  old.back.col$=RIGHT$(HEX$(XBIOS(7,color.index(0),-1)),3)
  VSETCOLOR 1,VAL(LEFT$(txt.col$)),VAL(MID$(txt.col$,2,1)),VAL(RIGHT$(txt.col$))
  VSETCOLOR 0,VAL(LEFT$(back.col$)),VAL(MID$(back.col$,2,1)),VAL(RIGHT$(back.col$))
RETURN
' **********
'
> PROCEDURE palette.box(x,y,h,w)
  ' *** show palette in rectangle (spectrum)
  ' *** left upper corner of rectangle at x,y
  ' *** rectangle-height h; width of one color-box w
  ' *** uses Standard Array color.index() and Standard Global black
  LOCAL arect.fill,fill.adr%,i,x1,x2
  x2=x+16*w+2
  COLOR black
  BOX x,y,x2,y+h
  arect.fill=-1
  fill.adr%=V:arect.fill
  IF low.res!
    FOR i=0 TO 15
      x1=ADD(SUCC(x),MUL(i,w))
      ARECT x1,SUCC(y),ADD(x1,w),PRED(ADD(y,h)),color.index(i),0,fill.adr%,0
    NEXT i
  ELSE IF med.res!
    FOR i=0 TO 3
      x1=ADD(SUCC(x),MUL(i,w))
      ARECT x1,SUCC(y),ADD(x1,w),PRED(ADD(y,h)),color.index(i),0,fill.adr%,0
    NEXT i
  ENDIF
RETURN
' **********
'
> PROCEDURE dim.colors(reg1,reg2,val)
  ' *** dim colors from VDI color-index reg1 to reg2 with val
  ' *** for val=1 color 254 (rgb) will become 143
  ' *** use this Procedure to darken the screen temporarily
  ' *** Procedure can also be used instead of CLS :
  ' ***          FOR i=0 TO 7
  ' ***            @dim.colors(0,15,1)
  ' ***            PAUSE 3
  ' ***          NEXT i
  ' *** uses Standard Array color.index() and Procedure Rgb.value
  LOCAL i,r,g,b
  FOR i=reg1 TO reg2
    @rgb.value(i,rgb$)
    r=MAX(PRED(VAL(LEFT$(rgb$))),0)
    g=MAX(PRED(VAL(MID$(rgb$,2,1))),0)
    b=MAX(PRED(VAL(RIGHT$(rgb$))),0)
    VSETCOLOR i,r,g,b
  NEXT i
RETURN
' **********
'
> PROCEDURE color.cycle(reg1,reg2,time)
  ' *** cycles colors from from VDI color-index reg1 to reg2
  ' *** cycles every time*0.005 seconds with EVERY (time=200 : 1 second)
  ' *** call again to stop the color-cycling : @color.cycle(0,0,0)
  ' *** uses Standard Array color.index()
  ' *** global :  COLOR.CYCLE!  COL.REG1  COL.REG2
  '
  IF NOT color.cycle!
    col.reg1=reg1
    col.reg2=reg2
    color.cycle!=TRUE
    EVERY time GOSUB cycle.once
  ELSE
    color.cycle!=FALSE
    EVERY STOP
  ENDIF
RETURN
' ***
> PROCEDURE cycle.once
  LOCAL col1%,col2%
  col1%=XBIOS(7,color.index(col.reg2),-1)
  FOR reg=col.reg1 TO PRED(col.reg2)
    col2%=XBIOS(7,color.index(reg),-1)
    ~XBIOS(7,color.index(reg),col1%)
    SWAP col1%,col2%
  NEXT reg
  ~XBIOS(7,color.index(col.reg2),col1%)
RETURN
' **********
'