rem ********************************************************
rem * JAICNV - Program to convert almost any unit
rem *
rem * Copyright (C) 1994  M.D. Nijdam
rem ********************************************************
rem * This program is free software; you can redistribute it and/or modify
rem * it under the terms of the GNU General Public License as published by
rem * the Free Software Foundation; either version 1, or (at your option)
rem * any later version.
rem *
rem * This program is distributed in the hope that it will be useful,
rem * but WITHOUT ANY WARRANTY; without even the implied warranty of
rem * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
rem * GNU General Public License for more details.
rem *
rem * You should have received a copy of the GNU General Public License
rem * along with this program; if not, write to the Free Software
rem * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
rem ********************************************************
rem *
APP jaicnv
	type $1000
	path "\dat"
	ext "dbf"
	icon "\pic\jaicnv.pic"
ENDA

PROC convert:
global pname$(8), version$(5)
global fform1$(255),tform1$(255)
global fform2$(255),tform2$(255)
global cdatafn$(128)
global chelpfn$(128)
local r%, valcat$(128)
REM * globals for dialog
global v1g$(128), v2g$(128), fnvalid%
global vprecis&, vwidth&, notat%, decsign$(1)
global memnr%
global catlist$(255), catnr%,  prevcnr%
global funtlst$(255), funtnr%, prevfnr%
global tuntlst$(255), tuntnr%, prevtnr%
global catunit$(100), catdesc$(100)
global fdesc$(100),tdesc$(100)

	pname$="Jaicnv"
	version$="v1.0"
	cdatafn$=dir$("\dat\jaicnv*.dbf")
	if cdatafn$ <> ""
		fnvalid%=opendat%:
	else
		cdatafn$="\dat\jaicnven.dbf"
		fnvalid%=0
		setdef:
		openhlp:
	endif
	disclaim:
	r%=0
	do
		r%=showopn%:
		if r%=0 :break :endif
		do
			if not fnvalid%
				fnvalid%=opendat%:
			endif
			if fnvalid% and prevcnr% <> catnr% and catnr% > 0
				readUnt:
				prevcnr%=catnr%
				prevfnr%=0
				prevtnr%=0
			endif
			if prevfnr% <> funtnr% or prevtnr% <> tuntnr%
				if funtnr% > 0 and tuntnr% > 0
					readFrm:
					prevfnr%=funtnr%
					prevtnr%=tuntnr%
				endif
			endif
			if funtnr% > 0 and tuntnr% > 0
				if r%=2
					valcat$=compute$:(fform1$, v1g$)
					if valcat$ <> ""
						valcat$=compute$:(fform2$, valcat$)
						if valcat$ <> "" :v2g$=valcat$ :endif
					endif
				endif
				if r%=3
					valcat$=compute$:(tform1$, v2g$)
					if valcat$ <> ""
						valcat$=compute$:(tform2$, valcat$)
						if valcat$ <> "" :v1g$=valcat$ :endif
					endif
				endif
			endif
			r%=cnvDlg%:
			if r%=0 :break :endif
			if r%>=4 :v1g$="0" :v2g$="0" :endif
			if r%=6 :funtnr%=0 :tuntnr%=0 :endif
			if r%=7 OR r%=8
				fnvalid%=0
			endif
		until 0
	until 0
ENDP

rem ********************************************************
rem * Show disclaimer
rem *
PROC disclaim:
	use B
	dINIT findstr$:("Disclaimer")
	first
	findfield("help: disclaimer",1,1,$01)
	if eof
		showerr:("NoDisclaim")
		stop
	else
		if B.msg$ <> "" :dText "", B.msg$ :endif
		if B.l1$ <> ""  :dText "", B.l1$  :endif
		if B.l2$ <> ""  :dText "", B.l2$  :endif
		if B.l3$ <> ""  :dText "", B.l3$  :endif
		if B.l4$ <> ""  :dText "", B.l4$  :endif
		if B.l5$ <> ""  :dText "", B.l5$  :endif
		if B.l6$ <> ""  :dText "", B.l6$  :endif
		if B.l7$ <> ""  :dText "", B.l7$  :endif
		dialog
	endif
ENDP

rem ********************************************************
rem * Show opening window for convert
rem * Also handle keypresses on it and
rem * showing menu
rem *
PROC showopn%:
local k%	   rem keycode
local h$(9)	rem list of valid keys
local a$(5)	rem procedure name to call

	Font 10,2
	At 4,3 :Print pname$+" "+version$
	Style 0
	findmsg:("panel: fatal", "Opening")
	At 3,5 :Print " "+B.msg$
	At 3,6 :Print " "+B.l1$
	At 3,7 :Print " "+B.l2$
	At 3,8 :Print " "+B.l3$
	At 3,9 :Print " "+B.l4$
	At 3,10 :Print " "+B.l5$
	if fnvalid%
		At 3,11 :Print " "+strsub$:(B.l6$, "%s1", cdatafn$)
	else
		At 3,11 :Print " "+B.l7$
	endif
	h$="ftmqsx"
	while 1
		k%=get
		if k%=$123		rem Help key
			dohelp:
			continue
		elseif k%=13	  rem Enter key
			break
		elseif k%=$122	rem Menu key
			mInit
			findmnu$:("Memory")
			mCard B.msg$,"M"+num$(memnr%,1)+B.l1$,%f,"M"+num$(memnr%,1)+B.l2$,%t,B.l3$,%m
			findmnu$:("Special")
			mCard B.msg$,B.l1$,%q,B.l2$,%s,B.l3$,%x
			k%=Menu
		elseif k% AND $200
			k%=k%-$200
		endif
		if k% AND (loc(h$,chr$(k%))<>0)
			a$="proc"+chr$(k%)
			@(a$):
		endif
	endwh
	return k%
ENDP

rem ********************************************************
rem * Show help information on screen.
rem * Loads help from database.
rem *
PROC dohelp:
local cnt%, r%
local title$(20)

	use B
	while 1
		cnt%=0
		title$=findstr$:("HelpTitle")
		dINIT title$+": "+pname$+" "+version$
		first
		while findfield("help:*",1,1,$01) AND cnt% < 8
			dText "", B.name$, $400
			cnt%=cnt%+1
			next
		endwh
		if cnt%=0 :break :endif	 rem No help.
		r%=dialog
		if r%=0 :break :endif	   rem Nothing selected
		cnt%=2
		first
		while findfield("help:*",1,1,$01) AND cnt% < r%
			cnt%=cnt%+1
			next
		endwh
		dINIT title$+": "+B.name$
		if B.msg$ <> "" :dText "", B.msg$ :endif
		if B.l1$ <> ""  :dText "", B.l1$  :endif
		if B.l2$ <> ""  :dText "", B.l2$  :endif
		if B.l3$ <> ""  :dText "", B.l3$  :endif
		if B.l4$ <> ""  :dText "", B.l4$  :endif
		if B.l5$ <> ""  :dText "", B.l5$  :endif
		if B.l6$ <> ""  :dText "", B.l6$  :endif
		if B.l7$ <> ""  :dText "", B.l7$  :endif
		dialog
	endwh
ENDP

rem ********************************************************
rem * Procedure to stop program
PROC procx:
	stop
ENDP

rem ********************************************************
rem * Procedure to handle preferences
rem *
PROC procq:
	findmsg:("panel: fatal", "Preferences")
	dInit B.msg$
	dChoice notat%,left$(B.l1$, loc(B.l1$,":")),right$(B.l1$,len(B.l1$)-loc(B.l1$,":"))
	dLong vprecis&,B.l2$,0,100
	dLong vwidth&,B.l3$,5,100
	dialog
ENDP

rem ********************************************************
rem * Procedure to save preferences as defaults in the
rem * database.
rem *
PROC procs:
	if not fnvalid%
		GIPrint findstr$:("DBNotOpen")
	else
		putdef:("Notation", num$(notat%,2))
		putdef:("ValPrecision", num$(vprecis&,3))
		putdef:("ValWidth", num$(vwidth&,3))
		putdef:("MemoryNr", num$(memnr%,1))
		GIPrint findstr$:("PrefSaved")
	endif
ENDP

rem ********************************************************
rem * Procedure to store From value in current memory
rem *
PROC procf:
	stomem:(v1g$)
ENDP

rem ********************************************************
rem * Procedure to store To value in current memory
rem *
PROC proct:
	stomem:(v2g$)
ENDP

rem ********************************************************
rem * Procedure to store value in current memory
rem *
PROC stomem:(v$)
local v
	onerr errnoval
	v=eval(v$)
	if memnr%=0 :m0=v :endif
	if memnr%=1 :m1=v :endif
	if memnr%=2 :m2=v :endif
	if memnr%=3 :m3=v :endif
	if memnr%=4 :m4=v :endif
	if memnr%=5 :m5=v :endif
	if memnr%=6 :m6=v :endif
	if memnr%=7 :m7=v :endif
	if memnr%=8 :m8=v :endif
	if memnr%=9 :m9=v :endif
	GIPrint findstr$:("MemStored")
	return
errnoval::
	onerr off
	showerr:("IllFormula")
ENDP

rem ********************************************************
rem * Procedure to change Calc memory name
rem *
PROC procm:
	findmsg:("panel: fatal", "Memory")
	dInit B.msg$
	memnr%=memnr%+1
	dChoice memnr%,B.l1$, "M0,M1,M2,M3,M4,M5,M6,M7,M8,M9"
	dialog
	memnr%=memnr%-1
ENDP

rem ********************************************************
rem * Show main dialog window for convert
rem * Returns exit code of dialog command.
rem *
PROC cnvDlg%:
local r%

	findmsg:("panel: fatal", "Main")
	dInit B.msg$
	if funtnr% > 0 and tuntnr% > 0
		if fform1$ <> "" AND fform2$ <> ""
			dEdit v1g$, fdesc$
		else
			dText fdesc$, v1g$
		endif
		if tform1$ <> "" AND tform2$ <> ""
			dEdit v2g$, tdesc$
		else
			dText tdesc$, v2g$
		endif
	else
		dText B.l1$, "0"
		dText B.l2$, "0"
	endif
	if catnr% > 0
		dChoice funtnr%, B.l3$, funtlst$
	else
		dText B.l3$, " "
	endif
	if catnr% > 0
		dChoice tuntnr%, B.l4$, tuntlst$
	else
		dText B.l4$, " "
	endif
	if fnvalid%
		dChoice catnr%, B.l5$, catlist$
	else
		dText B.l5$, " "
	endif
	dFile cdatafn$, B.l6$, 0
	r%=dialog
	return r%
ENDP

rem ********************************************************
rem * Compute result of formula, after filling in v
rem * as value in the formula where it contains 'xx'.
PROC compute$:(f$, v$)
local r, curdec$(1), formula$(255)

	formula$=f$
	curdec$=finddec$:
	if curdec$ <> decsign$
		if curdec$ = ","
			while loc(formula$, ",") > 0
				formula$=strsub$:(formula$, ",", ";")
			endwh
		endif
		while loc(formula$, decsign$) > 0
			formula$=strsub$:(formula$, decsign$, curdec$)
		endwh
		if curdec$ = "."
			while loc(formula$, ";") > 0
				formula$=strsub$:(formula$, ";", ",")
			endwh
		endif
	endif
	onerr errIll
	if loc(v$, "xx") :raise 1 :endif
	while loc(formula$, "xx") > 0
		formula$=strsub$:(formula$, "xx", v$)
	endwh
	r=eval(formula$)
	if notat% = 1 :return sci$(r,vprecis&,vwidth&) :endif
	if notat% = 2 :return fix$(r,vprecis&,vwidth&) :endif
	return gen$(r,vwidth&)
errIll::
	onerr off
	showerr:("IllFormula")
	return ""
ENDP

rem ********************************************************
rem * Find out what the current decimal character is.
rem * HACK: determines current sign by trying eval
rem *	   with ",". If error is generated, "." is assumed.
rem *
PROC finddec$:
	onerr usedot
	eval("1,2")
	return ","
usedot::
	return "."
ENDP
	
rem ********************************************************
rem * Read categories from database
rem * Return comma separated string of categories
rem *
PROC readCat:
	use A
	catlist$=""
	first
	while findfield("*category:*",1,1,$01)
		if catlist$ <> ""
			catlist$=catlist$+","
		endif
		catlist$=catlist$+A.fdesc$
		next
	endwh
	if catlist$ = ""
		fnvalid%=0
		shower1:("DBNoCat", cdatafn$)
	endif
ENDP

rem ********************************************************
rem * Read units for selected category from database.
rem * Build 2 comma separated strings of units
rem * (from and to list)
rem *
PROC readUnt:
local cnt%

	use A
	cnt%=1
	first
	while findfield("*category:*",1,1,$01)
		if cnt% >= catnr% :break :endif
		cnt%=cnt%+1
		next
	endwh
	catunit$=A.tunit$
	catdesc$=A.tdesc$
	funtlst$=catunit$
	tuntlst$=catunit$
	first
	while findfield(catunit$,1,2,$01)
		if loc(A.funit$, "category") = 0
			if A.funit$ <> catunit$
				if len(funtlst$)+len(A.funit$) > 254
					goto errlst
				endif
				funtlst$=funtlst$+","
				funtlst$=funtlst$+A.funit$
				if A.fact$ <> ""
					if len(tuntlst$)+len(A.funit$) > 254
						goto errlst
					endif
					tuntlst$=tuntlst$+","
					tuntlst$=tuntlst$+A.funit$
				endif
			endif
			if A.tunit$ <> catunit$
				if len(tuntlst$)+len(A.tunit$) > 254
					goto errlst
				endif
				tuntlst$=tuntlst$+","
				tuntlst$=tuntlst$+A.tunit$
				if A.fact$ <> ""
					if len(funtlst$)+len(A.tunit$) > 254
						goto errlst
					endif
					funtlst$=funtlst$+","
					funtlst$=funtlst$+A.tunit$
				endif
			endif
		endif
		next
	endwh
	return
errlst::
	shower2:("ulistOverflow", A.funit$, A.tunit$)
	return
ENDP

rem ********************************************************
rem * Read factor or formula from database
rem * for selected units
rem * Builds 2 formula strings (from to to
rem * and to to from). Also sets descriptions
rem *
PROC readFrm:
global fformX$(255), tformX$(255)
local sel$(100)

	sel$=listent$:(funtlst$, funtnr%)
	if sel$ = ""
		funtnr%=0
	else
		fdesc$=findunt$:(sel$)
		fform1$=fformX$
		tform2$=tformX$
	endif
	sel$=listent$:(tuntlst$, tuntnr%)
	if sel$ = ""
		tuntnr%=0
	else
		tdesc$=findunt$:(sel$)
		fform2$=tformX$
		tform1$=fformX$
	endif
ENDP

rem ********************************************************
rem * Get the entnr%-th entry from the
rem * comma separated list$
rem * Returns empty string if not existing
rem *
PROC listent$:(list$, entnr%)
local t$(255), sel$(100), cnt%

	cnt%=1
	t$=list$
	while cnt% < entnr% and loc(t$,",") > 0
		t$=right$(t$,len(t$)-loc(t$,","))
		cnt%=cnt%+1
	endwh
	if cnt% < entnr%
		sel$=""
	elseif loc(t$,",") = 0
		sel$=t$
	else
		sel$=left$(t$,loc(t$,",")-1)
	endif
	return sel$
ENDP

rem ********************************************************
rem * Look in database for conversion from
rem * unit$ to catunit$ or vice versa.
rem * Return description of unit$
rem * Sets global variables fformX$ and
rem * tformX with formulas to go from
rem * unit$ to catunit$ and vice versa.
PROC findunt$:(unit$)
local desc$(100)

	use A
	if unit$ = catunit$
		desc$=catdesc$
		fformX$="xx"
		tformX$="xx"
	else
		fformX$ = ""
		tformX$ = ""
		first
		while findfield(unit$,1,2,$01)
			rem Search all occurrences.
			rem with formulas more than one
			rem is possible.
			if A.funit$ = catunit$
				desc$ = A.tdesc$
				if A.fact$ = ""
					tformX$ = A.form$
				else
					fformX$ = "(xx/"+A.fact$+")"
					tformX$ = "(xx*"+A.fact$+")"
				endif
			elseif A.tunit$ = catunit$
				desc$ = A.fdesc$
				if A.fact$ = ""
					fformX$ = A.form$
				else
					fformX$ = "(xx*"+A.fact$+")"
					tformX$ = "(xx/"+A.fact$+")"
				endif
			endif
			next
		endwh
	endif
	return desc$
ENDP

rem ********************************************************
rem * Set default values. Tries to read them from database.
rem *

PROC setdef:
	chelpfn$=getdef$:("HelpFile", "\dat\jaicnven.hlp")
	notat%=val(getdef$:("Notation", "3"))
	vprecis&=val(getdef$:("ValPrecision", "5"))
	vwidth&=val(getdef$:("ValWidth", "20"))
	decsign$=left$(getdef$:("DecimalSign", "."), 1)
	memnr%=val(getdef$:("MemoryNr", "0"))
ENDP

rem ********************************************************
rem * Open Data file
rem * Also read defaults,opens help fife,
rem * initializes global variables that
rem * indicate a selected item, and reads
rem * the categories.
rem *
PROC opendat%:
	if not exist(cdatafn$)
		shower1:("FileNotFound",cdatafn$)
		fnvalid%=0
	else
		trap use B
		trap close
		trap use A
		trap close
		open cdatafn$,A,funit$,tunit$,fact$,form$,fdesc$,tdesc$
		fnvalid%=-1
		setdef:
		openhlp:
		if fnvalid%
			catnr%=0  :prevcnr%=0
			funtnr%=0 :prevfnr%=0
			tuntnr%=0 :prevtnr%=0
			readCat:
		endif
	endif
	return fnvalid%
ENDP

rem ********************************************************
rem * Open help and error message file
rem *
PROC openhlp:
	if not exist(chelpfn$)
		alert("Internal error: helpfile not found", chelpfn$)
		stop
	else
		open chelpfn$,B,type$,name$,msg$,l1$,l2$,l3$,l4$,l5$,l6$,l7$,l8$
	endif
ENDP

rem ********************************************************
rem * Show error message named errname$.
rem * The message string is retrieved from a
rem * database using errname$ as index.
rem * Expect to replace at most two arguments in
rem * message string with arg1$ and arg2$
rem * args in string look like "%s1" and "%s2"
rem *
PROC shower2:(errname$, arg1$, arg2$)
local str1$(100), str2$(100)
	findmsg:("error:", errname$)
	str1$=strsub$:(B.msg$, "%s1", arg1$)
	str1$=strsub$:(str1$, "%s2", arg2$)
	str2$=strsub$:(B.l1$, "%s1", arg1$)
	str2$=strsub$:(str2$, "%s2", arg2$)
	alert(str1$, str2$)
	if loc(B.type$, "fatal") <> 0
		stop
	endif
ENDP

rem ********************************************************
rem * Wrapper functions for errors with 0 and 1 arg.
rem *
PROC showerr:(errname$)
	shower2:(errname$, "%s1", "%s2")
ENDP

PROC shower1:(errname$, arg$)
	shower2:(errname$, arg$, "%s2")
ENDP

rem ********************************************************
rem * Find string in database
rem *
PROC findstr$:(name$)
	findmsg:("string:", name$)
	if eof
		alert("Internal error, string "+name$+" not found", "database incomplete")
		stop
	endif
	return B.msg$
ENDP

rem ********************************************************
rem * Find menu in database
rem *
PROC findmnu$:(name$)
	findmsg:("menu:", name$)
	if eof
		alert("Internal error, menu "+name$+" not found", "database incomplete")
		stop
	endif
	return B.msg$
ENDP

rem ********************************************************
rem * Gets default value from database.
rem * If database not open or name$ not found, return def$
rem * else return value from database field fdesc$
rem *
PROC getdef$:(name$, def$)
	if not fnvalid%
		return def$
	else
		use A
		first
		while findfield(name$,2,1,$01)
			if loc(A.funit$, "default:") <> 0
				break
			endif
			next
		endwh
	endif
	if eof
		return def$
	else
		return A.fdesc$
	endif
ENDP

rem ********************************************************
rem * Puts default value in database.
rem * If database not open, nothing happens.
rem * If name$ not found, a new record is created for it.
rem *
PROC putdef:(name$, val$)
	if fnvalid%
		use A
		first
		while findfield(name$,2,1,$01)
			if loc(A.funit$, "default:") <> 0
				break
			endif
			next
		endwh
		if eof
			A.funit$="default:"
			A.tunit$=name$
			A.fdesc$=val$
			Append
		else
			A.fdesc$=val$
			Update
		endif
	endif
ENDP

rem ********************************************************
rem * Find a record for a message in help file
rem * Sets current record.
rem * Stops program if not found
rem *
PROC findmsg:(type$, name$)
	use B
	first
	while findfield(name$,2,1,$01)
		if loc(B.type$, type$) <> 0
			break
		endif
		next
	endwh
	if eof AND loc(type$, "fatal") <> 0
		alert("Internal error, "+type$+" msg not found:", name$)
		stop
	endif
ENDP

rem ********************************************************
rem * Substitute string org$ by repl$ in str$.
rem * Return resulting string.
rem * If org$ does not exist in str$, str$ is returned.
rem *
PROC strsub$:(str$, org$, repl$)
local l%, f$(255)
	l%=loc(str$, org$)
	if l%>0
		f$=left$(str$,l%-1)
		f$=f$+repl$
		l%=l%+len(org$)-1
	endif
	if l%<len(str$)
		f$=f$+right$(str$,len(str$)-l%)
	endif
	return f$
ENDP