{
 Screen Color Prefs Tool
 Started September 19, 1995
 Version 1.0 finished October 03, 1995
 Programmer: Herbert Breuer, e-mail: herby@grex.cyberspace.org
}
'----------------------------
' include files
'----------------------------
#include <EasyRequest.h>	' don't forget to link EasyRequest.o!!
'----------------------------
' shared libraries declarations
'----------------------------
LIBRARY graphics
LIBRARY intuition
'----------------------------
' shared library function declarations
'----------------------------
DECLARE FUNCTION GetRGB4&(_ColorMap&, Count&) LIBRARY graphics
DECLARE FUNCTION LoadRGB4&(_ViewPort&, ColorTable&, Count%) ~
		 LIBRARY graphics
'DECLARE FUNCTION LockPubScreen&(Name$) LIBRARY intuition
'DECLARE FUNCTION UnlockPubScreen&(Name$,ScreenPtr&) LIBRARY intuition
'----------------------------
' variable definitions
'----------------------------
' Menu
'----------------------------
' Menu Constants (prefixes: c=command, m=menu, i=menu item)

' Menu Modes
CONST cDisable	 =0
CONST cEnable 	 =1

'..Project Menu
CONST mProject	 =1
CONST iOpen	 =1
CONST iSave	 =2
CONST iDelete	 =3
CONST iSep	 =4
CONST iAbout	 =5
CONST iQuit	 =6
'----------------------------
' others
'----------------------------
ADDRESS _ViewPort
ADDRESS _ColorMap
ADDRESS _ColorMapPtr

CONST	COLORS		=  32	' RGB4 allows only 32 colors
CONST	newname		=  2
CONST	yes		=  1
CONST	no		=  0

CONST	having_fun	= -1&

LONGINT  answer
SHORTINT save_flag	=  0
SHORTINT max_win_colors
SHORTINT y_pos_color_area
SHORTINT color_select
SHORTINT gd_id

ScreenName$		="Workbench"

id_string$		= "wbcolors.map" ' that will be written with the file
STRING id_test SIZE 14

default_dir$		= "SYS:Prefs/Presets"

STRING full_name	= "" ' nobody knows how long that can be
			     ' but I think 1024 Bytes will be enough
STRING dir_name		= ""

DIM r(COLORS), g(COLORS), b(COLORS)	' reserve space for the colors
'----------------------------
' sub programs
'----------------------------
{
This sub program prints all the messages to inform the user.
}
SUB LONGINT display_msg_req(SHORTINT msg_no)

STRING bodystring SIZE 200
STRING gadtext SIZE 30
select_cancel$="Please select 'Cancel' to terminate." '36 Zeichen

CASE
  msg_no =  202 : bodystring="           Object in use!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  203 : bodystring="           Object exists!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  204 : bodystring="        Directory not found!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  205 : bodystring="         Object not found!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  206 : bodystring="             Bad name!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  210 : bodystring="           Invalid name!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  212 : bodystring="      Object is of wrong type!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  213 : bodystring="       Disk is not validated!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  214 : bodystring="      Disk is write protected!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  218 : bodystring="       Device is not mounted!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  221 : bodystring="           Disk is full!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  222 : bodystring="  File is protected from deletion!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  223 : bodystring="      File is write protected!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  224 : bodystring="      File is read protected!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  225 : bodystring="          Not a DOS disk!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  226 : bodystring="         No disk in drive!"+CHR$(10)+ ~
		  select_cancel$:gadtext="Cancel"
  msg_no =  700 : bodystring="Not enough memory to open the window!" ~
		  +CHR$(10)+"   Please free some and try again.":gadtext="OK"
  msg_no =  999 : bodystring="      Not enough memory !" ~
		  +CHR$(10)+ "Please free some and try again.":gadtext="OK"
  msg_no = 1000 : bodystring="ScreenColorPrefsV1.0 programmed in ACE."+CHR$(10)+ ~
		  "    Copyright © Herbert Breuer 1995":gadtext="ACE is good!"
  msg_no = 1001 : bodystring="Current colors are not saved!"+CHR$(10)+ ~
		  " Do you really want to quit?":gadtext="Yes|No"
  msg_no = 1002 : bodystring="Colormap file already exists!"+CHR$(10)+ ~
		  "        Overwrite it?":gadtext="Yes|New name|No"
  msg_no = 1003 : bodystring="Do you want to change the name?" ~
		  :gadtext="Yes|No"
  msg_no = 1004 : bodystring="  No file name specified!"+CHR$(10)+ ~
		  "Do you want to specify one?":gadtext="Yes|No"
  msg_no = 1005 : bodystring="File doesn't exist!"+CHR$(10)+ ~
                  " Load another one?":gadtext="Yes|No"
  msg_no = 1006 : bodystring="File is not a ScreenColorPrefs file!"+CHR$(10)+ ~
                             "   Do you want to try again ?":gadtext="Yes|No"
  msg_no = 1007 : bodystring="Are you really sure?":gadtext="Yes|No"

END CASE

  display_msg_req = EasyRequest("ScreenColorPrefs Request",bodystring,gadtext)

END SUB
'----------------------------
SUB SHORTINT file_exists(STRING file_name)
	OPEN "I",#255,file_name
	IF HANDLE(255) THEN
		file_exists=0
	ELSE
		file_exists=1
	END IF
	CLOSE #255
END SUB
'----------------------------
SUB SHORTINT proof_name(STRING full_name)
SHARED dir_name
	length%=LEN(full_name)
	pos%=INSTR(length%,full_name,":")
	IF pos%=0 THEN pos%=INSTR(length%,full_name,"/")
	FOR i=length% TO 1 STEP -1
		test%=INSTR(i,full_name,"/")
		IF test%<>0 THEN EXIT FOR
	NEXT
	IF test%=0 THEN
		FOR i=length% TO 1 STEP -1
			test%=INSTR(i,full_name,":")
			IF test%<>0 THEN EXIT FOR
		NEXT
	END IF
	dir_name=LEFT$(full_name,i)
	proof_name=pos%
END SUB
'----------------------------
SUB save_map(STRING directory_name)

SHARED	r, g, b, full_name, dir_name, save_flag, id_string$, max_win_colors
SHARED	answer

save_requester:
	save_map$=FILEBOX$("saving ColorMap ...",directory_name)
	IF save_map$="" THEN EXIT SUB

	full_name=save_map$

	proof=proof_name(save_map$)
	directory_name=dir_name
	IF proof<>0 THEN
		answer=display_msg_req(1004)
		IF answer=yes THEN GOTO save_requester
		EXIT SUB
	END IF

	proof=file_exists(save_map$)
	IF proof<>0 THEN GOTO save_file
		answer=display_msg_req(1002)
		IF answer=yes THEN GOTO save_file
		IF answer=newname THEN GOTO save_requester
		EXIT SUB

save_file:
	OPEN "O",#1,save_map$

	error_no=ERR
	IF error_no=52 THEN GOTO skip	' file doesn't exist, that's OK here
	IF error_no<>0 THEN CALL display_msg_req(error_no):EXIT SUB
skip:
	WRITE #1,id_string$

	FOR i=0 to max_win_colors
		WRITE #1,r(i),g(i),b(i)
	NEXT

	error_no=ERR
	IF error_no<>0 THEN CALL display_msg_req(error_no)

	CLOSE #1
	save_flag=1
END SUB
'----------------------------
SUB load_map(STRING directory_name)

SHARED	r, g, b, full_name, dir_name, id_string$, id_test, save_flag
SHARED	max_win_colors, answer

load_requester:
	load_map$=FILEBOX$("loading Colormap ...",directory_name)
	IF load_map$="" THEN EXIT SUB

	full_name=load_map$

	proof=proof_name(load_map$)
	directory_name=dir_name
	IF proof<>0 THEN
		answer=display_msg_req(1004)
		IF answer=yes THEN GOTO load_requester
		EXIT SUB
	END IF

	proof=file_exists(load_map$)
	IF proof<>0 THEN
		answer=display_msg_req(1005)
		IF answer=yes THEN GOTO load_requester
		EXIT SUB
	END IF

	OPEN "I",#2,load_map$

	error_no=ERR
	IF error_no<>0 THEN CALL display_msg_req(error_no):EXIT SUB

	INPUT #2,id_test

	IF id_test<>id_string$ THEN
	   CLOSE #2
	   answer=display_msg_req(1006)
	   IF answer=yes THEN GOTO load_requester
	   EXIT SUB
	END IF

	FOR i=0 to max_win_colors
		INPUT #2,r(i),g(i),b(i)
	NEXT

	error_no=ERR
	IF error_no<>0 THEN CALL display_msg_req(error_no)

	save_flag=0
	CLOSE #2
END SUB
'----------------------------
SUB delete_map(STRING directory_name)

SHARED	dir_name, id_string$, id_test, answer

delete_requester:
	delete_map$=FILEBOX$("deleting...",directory_name)
	IF delete_map$="" THEN EXIT SUB

	proof=proof_name(delete_map$)
	directory_name=dir_name
	IF proof<>0 THEN
		answer=display_msg_req(1004)
		IF answer=yes THEN GOTO delete_requester
		EXIT SUB
	END IF

	OPEN "I",#3,delete_map$

	error_no=ERR
	IF error_no<>0 THEN CALL display_msg_req(error_no):EXIT SUB

	INPUT #3,id_test

	error_no=ERR
	IF error_no<>0 THEN CALL display_msg_req(error_no):CLOSE #3:EXIT SUB

	CLOSE #3
	IF id_test<>id_string$ THEN
	   answer=display_msg_req(1006)
	   IF answer=yes THEN GOTO delete_requester
	   EXIT SUB
	END IF

	proof=file_exists(delete_map$)
	IF proof=0 THEN
	   answer=display_msg_req(1007)
	   IF answer=yes THEN KILL delete_map$
	END IF
	error_no=ERR
	IF error_no<>0 THEN CALL display_msg_req(error_no)
END SUB
'----------------------------
SUB setup_menus

'..Project Menu

  MENU mProject,0,cEnable,	   	" Project "
  MENU mProject,iOpen,cEnable,	   	" Open   ","O"
  MENU mProject,iSave,cEnable,		" Save   ","S"
  MENU mProject,iDelete,cEnable,   	" Delete ","D"
  MENU mProject,iSep,cDisable,  	"------------"
  MENU mProject,iAbout,cEnable,	   	" About  "
  MENU mProject,iQuit,cEnable,	   	" Quit   ","Q"

END SUB
'----------------------------
SUB setup_color_gadgets(SHORTINT number)

SHARED y_pos_color_area, r, g, b

SHORTINT i

CONST xl=10%	' left edge
CONST xr=30%	' right edge
CONST xd=28%	' x-distance between the gadgets

CONST yo=5%	' top edge
CONST yu=15%	' bottom edge
CONST yd=13%	' y-distance between the gadgets

	yoa=yo : yua=yu ' set the first line y-offsets

	FOR i=0 to number

	    IF i=8  THEN
		mul=i-8
		xla=0	  ' set x-offset to 0
		xra=0	  ' dto.
		yoa=yo+yd ' add diff top edge
		yua=yu+yd ' add diff bottom edge
	    END IF

	    IF i=16 THEN
		mul=i-16
		xla=0	  ' set x-offset to 0
		xra=0	  ' dto.
		yoa=yo+yd*2 ' add diff top edge
		yua=yu+yd*2 ' add diff bottom edge
	    END IF

	    IF i=24 THEN
		mul=i-24
		xla=0	  ' set x-offset to 0
		xra=0	  ' dto.
		yoa=yo+yd*3 ' add diff top edge
		yua=yu+yd*3 ' add diff bottom edge
	    END IF

	    IF i<8  THEN mul = i	: GOTO cal_pos
	    IF i<16 THEN mul = i-8	: GOTO cal_pos
	    IF i<24 THEN mul = i-16	: GOTO cal_pos
	    IF i<32 THEN mul = i-24

	cal_pos:
	    xla=xl+(xd*mul)		' calculate the gadget position
	    xra=xr+(xd*mul)

	    GADGET i+1,ON," ",(xla,yoa)-(xra,yua),1

	    COLOR i

	    AREA      ((xla+2),(yoa+1)) ' fill the gadget with the color
	    AREA STEP (15,0)
	    AREA STEP (0,7)
	    AREA STEP (-15,0)
	    AREA STEP (0,-7)
	    AREAFILL

	NEXT

	' draw a recessed Bevel-Box around them
	BEVELBOX (4,yo-3)-(232,yua+2),2

	COLOR 0

 	y_pos_color_area=yua+6

	AREA      (6,y_pos_color_area)
	AREA STEP (52,0)
	AREA STEP (0,34)
	AREA STEP (-52,0)
	AREA STEP (0,-34)
	AREAFILL

	' draw a raised Bevel-Box
	BEVELBOX (4,yua+5)-(60,yua+41),1

	GADGET 100,1,15,(65,yua+5)-(232,yua+15),4  ' slider gadgets
	GADGET 101,1,15,(65,yua+18)-(232,yua+28),4 ' to set RGB
	GADGET 102,1,15,(65,yua+31)-(232,yua+41),4 ' values

	GADGET MOD 100,r(0),15
	GADGET MOD 101,g(0),15
	GADGET MOD 102,b(0),15

	SETXY 240,yua+13:COLOR 1:PRINTS "R";r(0);:COLOR 0:SETXY 290,yua+21
	SETXY 240,yua+26:COLOR 1:PRINTS "G";g(0);:COLOR 0:SETXY 290,yua+34
	SETXY 240,yua+39:COLOR 1:PRINTS "B";b(0);:COLOR 0

END SUB
'----------------------------
main:
    IF SYSTEM < 37 THEN
	MSGBOX " Workbench V2.04 or higher required! "," I see " : STOP
    END IF

	FONT "topaz.font",8		' only topaz 8 allowed

	WINDOW 1,,(10,10)-(11,11),32	' just for getting the current values

	max_win_colors=Window(6)	' get the max no. of colors

	_winptr&=WINDOW(7)
	IF _winptr&=0 THEN CALL display_msg_req(700) : STOP
	' if the msg win can be opened, then we have more memory again :)

	WINDOW CLOSE 1

	color_select=0		' default color = background
	dir_name=default_dir$	' set default dir

	GOSUB get_curr_colors	' get the current color values

	' allocate memory for the colormap used by LoadRGB4
	_ColorMapPtr=ALLOC(max_win_colors*6,7)
	IF _ColorMapPtr=0 THEN CALL display_msg_req(999) : STOP

	IF max_win_colors >31 THEN max_win_colors = 31

	IF max_win_colors < 8  THEN win_height% = 82 : GOTO open_win
	IF max_win_colors < 16 THEN win_height% = 95 : GOTO open_win
	IF max_win_colors < 32 THEN win_height% = 121

open_win:
	WINDOW 1,"ScreenColorPrefs",(10,10)-(296,win_height%),30 '254

	_winptr&=WINDOW(7)
	IF _winptr&=0 THEN CALL display_msg_req(700) : STOP

	setup_color_gadgets(max_win_colors)
	setup_menus()

	ON WINDOW GOSUB quit
	ON MENU GOSUB handle_menu
	ON GADGET GOSUB handle_gadgets

	WINDOW ON
	MENU ON
	GADGET ON

	WHILE having_fun
	    SLEEP
	WEND
'----------------------------
handle_menu:

    itemNum = MENU(1) ' get the MenuItemNo.

  CASE 
    itemNum = iOpen  	: CALL load_map(dir_name):GOSUB set_new_colormap
    itemNum = iSave	: CALL save_map(dir_name)
    itemNum = iDelete	: CALL delete_map(dir_name)
    itemNum = iAbout 	: CALL display_msg_req(1000)
    itemNum = iQuit	: GOSUB quit
  END CASE

RETURN
'----------------------------
set_new_colormap:

ADDRESS _Map ' temp. Ptr.

	FOR i=0 TO max_win_colors

		red=SHL(r(i),8)	' read the values and
		gre=SHL(g(i),4)	' shift them in the right place
		new_color=red + gre + b(i) ' build the color
		_Map=_ColorMapPtr+(i*2)	   ' calculate the offset
		POKEW _Map,new_color	   ' write the color into the map
	NEXT

	' set theses colors
	LoadRGB4(_ViewPort,_ColorMapPtr,max_win_colors+1)

	color_select=0 ' background = default
	GOSUB set_current_values ' actualise the values
	GOSUB print_color_values
RETURN
'----------------------------
handle_gadgets:

    gd_id=GADGET(1)		' get the gadget id

	IF gd_id >99 THEN	' sliders ?

		save_flag=0	' color changed set flag = not saved
		slider_pos=GADGET(3) ' get the current position

		IF gd_id=100 THEN r(color_select)=slider_pos
		IF gd_id=101 THEN g(color_select)=slider_pos
		IF gd_id=102 THEN b(color_select)=slider_pos

		r_new!=r(color_select)/15 ' calculate them,
		g_new!=g(color_select)/15 ' so that they are in
		b_new!=b(color_select)/15 ' range from 0....1

		' set the new color
		PALETTE color_select,r_new!,g_new!,b_new!
		GOSUB print_color_values  ' actualise the values
	ELSE
		--gd_id			  ' color = gadget id - 1
		color_select = gd_id	  ' id = color
		GOSUB set_current_values  ' actualise the values
		GOSUB print_color_values
	END IF
RETURN
'----------------------------
set_current_values:

	COLOR color_select		  ' set this color

	AREA      (6,y_pos_color_area)	  ' fill the color display
	AREA STEP (52,0)
	AREA STEP (0,34)
	AREA STEP (-52,0)
	AREA STEP (0,-34)
	AREAFILL

	GADGET MOD 100,r(color_select),15 ' set the sliders
	GADGET MOD 101,g(color_select),15
	GADGET MOD 102,b(color_select),15
RETURN
'----------------------------
print_color_values:
	COLOR 0		' erase first the old values

	AREA      (249,y_pos_color_area)
	AREA STEP (52,0)
	AREA STEP (0,34)
	AREA STEP (-52,0)
	AREA STEP (0,-34)
	AREAFILL

	' now print the new values
	SETXY 249,y_pos_color_area+7
	COLOR 1:PRINTS r(color_select);:COLOR 0:SETXY 290,y_pos_color_area+15

	SETXY 249,y_pos_color_area+20
	COLOR 1:PRINTS g(color_select);:COLOR 0:SETXY 290,y_pos_color_area+28

	SETXY 249,y_pos_color_area+33
	COLOR 1:PRINTS b(color_select);:COLOR 0
RETURN
'----------------------------
get_curr_colors:

'	_Screen&=LockPubScreen(ScreenName$) ' get the screen pointer
'	UnlockPubScreen(0,_Screen&)	    ' unlock the screen again

	_Screen&=PEEKL(_winptr&+46)	' get the screen pointer
	_ViewPort=_Screen&+44		' calculate the address
	_ColorMap=PEEKL(_ViewPort+4)	' get the pointer of the colormap
	FOR n&=0 TO max_win_colors	' get the current colors
		color&=GetRGB4(_ColorMap,n&)
		b(n&)=color& AND &H0F
		g(n&)=SHR((color& AND &HF0),4)
		r(n&)=SHR((color& AND &H0F00),8)
	NEXT
	' all values MUST be long aligned! see RKRM Includes and Autodocs V37
RETURN
'----------------------------
quit:
    IF save_flag=0 THEN			' colormap saved?
       answer=display_msg_req(1001)	' no! ask
       IF answer=no THEN RETURN		' don't quit
    END IF
    MENU CLEAR 				' clear the menu strip
    FOR i=102 TO 100 STEP -1		' the sliders
      GADGET CLOSE i
    NEXT
    FOR i=max_win_colors TO 1 STEP -1	' the color gadgets
      GADGET CLOSE i
    NEXT
    WINDOW CLOSE 1			' now close the window
END					' bye, bye
'----------------------------