Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : WINDOWS.ZIP
Filename : CALC.PRG

 
Output of file : CALC.PRG contained in archive : WINDOWS.ZIP
*----------------------->LOGITEK<--------------------------------------
*
* All Registered Users are free to modify and use this source code
* as they see fit, with no royalties, obligations or fees to LOGITEK.
*
*-----------------------------------------------------------------------
* y,x - upper left corner of calc. coordinate on screen
* calcwind - window select area to use
* color1,color2 - color strings
*************************************************************************

parameters color1,color2,y,x,calcwind

* if necessary, adjust coordinates so that calculator does not
* exceed the screen

result = 0
ok = .t.
x = IF(x > 48,48,x)
y = IF(y > 11,11,y)

DO disp_calc with color1,color2 && display calculator

op = "" && operator
op_old = "" && LASTKEY operator
mov = .t. && flag: move calculator
result = 0 && result
noerr = .t. && error flag
*
* main loop - do it until entry is "x" or "e" (esc)
*
DO WHILE ! (op $ "XE" )
*
* read first operand and first operator
*
num = "0"
DO getnum WITH num,op,x,y,op # "="
*
* handle result key, end, or clear entry
*
IF op $ "=XEC"
IF ((op = "X" ) .AND. (op_old # "=" )) .OR. (op = "=" )
result = val(num)
ENDIF ((op = "X" ) .AND. (op_old # "=" )) .OR. (op = "=" )
op_old = op
wprint(2,3,STR(result,21,4))
wprint(2,24," ")
LOOP
ENDIF op $ "=XEC"
*
* store first operand into result
*
result = val(num)
*
* read more operands and operators
*
DO WHILE .t.
op_old = op
DO getnum WITH num,op,x,y,.f.
*
* handle clear entry or end
*
IF op $ "XEC"
EXIT
ENDIF op $ "XEC"
*
* calculate...
*
result = calculate(result,num,op_old)
*
* overflow or divide by zero error ?
*
noerr = IF(result = 9999999999999999999999,.f.,.t.)
*
* display result
*
wprint(2,3,STR(result,21,4))
wprint(2,26," ")
*
* handle result key
*
IF op = "="
op_old = op
EXIT
ENDIF op = "="
ENDDO WHILE .t.
ENDDO WHILE ! (op $ "xe" )
*
* set flag if result is ok
*
ok = IF(((op = "X" ) .AND. noerr),.t.,.f.)
*
*

wclose() && close window, restore screen
wrelease() && release window from memory

RETURN
*
* function to calculate the results
*
FUNCTION calculate
PARAMETERS result,num,operator
DO CASE
CASE operator = "+"
RETURN(result + val(num))
CASE operator = "-"
RETURN(result - val(num))
CASE operator = "*"
RETURN(result * val(num))
CASE operator = "/"
IF val(num) = 0
sound(800,10)
RETURN(9999999999999999999999)
noerr = .f.
ELSE
RETURN(result / val(num))
noerr = .t.
ENDIF val(num) = 0
ENDCASE
*
* read a number into "num" and operand into "op"
*
* location for display is determined by x and y
*
* first clear the display if cl = .t.
*
PROCEDURE getnum
PARAMETERS num,op,x,y,cl
num = "0"
inp_dec = .f.
mant_len = 1
dec_len = 0
*
* clear display if needed
*
IF cl
wprint(2,3,STR(val(num),16,0) + " ")
wprint(2,24," ")
ENDIF cl
*
*main loop for character entry
*
DO WHILE .t.
ch = getkey()
DO CASE
CASE ch $ "+-*/=XCE" && operands AND special keys
op = ch
wprint(2,24,ch)
EXIT
CASE ch = "B" && backspace (CLEAR entry)
num = "0"
mant_len = 1
dec_len = 0
inp_dec = .f.
wprint(2,3,STR(val(num),16,0) + " ")
wprint(2,24," ")
CASE ch = "V" && change sign
num = IF(((inp_dec) .AND. (dec_len=0)), ;
LTRIM(STR(-val(num),16,0)) + "." , ;
LTRIM(STR(-val(num),16,dec_len)))
CASE ch = "." && DECIMALS point
IF inp_dec && already there ?
sound(800,10)
ELSE && no, DO it
num = num + "."
inp_dec = .t. && DECIMALS flag
ENDIF inp_dec && already there ?
OTHERWISE && enter a number KEY
IF ! inp_dec && we are left of dec. point
IF num = "0" && just started ?
num = ch && this is our first digit
ELSE
IF mant_len = 10 && overflow ?
sound(800,10)
ELSE
num = num + ch && no, i LIKE this digit
mant_len = mant_len + 1 && digit counter
ENDIF mant_len = 10 && overflow ?
ENDIF num = "0" && just started ?
ELSE && we INPUT DECIMALS now
IF dec_len = 4 && overflow ?
sound(800,10)
ELSE && no, we LIKE this digit
num = num + ch
dec_len = dec_len + 1 && DECIMALS counter
ENDIF dec_len = 4 && overflow ?
ENDIF ! inp_dec && we are left of dec. point
ENDCASE
*
* display the number
*
IF inp_dec && DECIMALS point ?
IF dec_len = 0 && no DECIMALS
wprint(2,3,STR(val(num),16) + ". ")
ELSE && there are DECIMALS
wprint(2,3,STR(val(num),17+dec_len,dec_len) + SPACE(4-dec_len))
ENDIF dec_len = 0 && no DECIMALS
ELSE && no DECIMALS point
wprint(2,3,STR(val(num),16) + " ")
ENDIF inp_dec && DECIMALS point ?
wprint(2,24," ")
ENDDO WHILE .t.
RETURN
*
* read keyboard entry
*
FUNCTION getkey
DO WHILE .t.
*
* check the arrow keys if move is still active
*
DO WHILE .t.
c = INKEY(0)
IF mov .AND. ((c=5) .OR. (c=24) .OR. (c=19) ;
.OR. (c=4) .OR. (c=26) .OR. ;
(c=2) .OR. (c=1) .OR. (c=6))
DO mov_calc WITH c
ELSE
EXIT
ENDIF mov .AND. ((c=5) .OR. (c=24) .OR. (c=19) ;
ENDDO WHILE .t.
ch = UPPER(CHR(c))
DO CASE
CASE ch $ "0123456789+-*/=VXC." && numbers OR special keys
RETURN(ch)
CASE c = 8 && back SPACE
RETURN( "B" )
CASE ch = "," && comma -->dot (TO make the
RETURN( "." )
CASE c = 13 && RETURN --> =
RETURN( "=" )
CASE c = 27 && esc
RETURN( "E" )
OTHERWISE && we dont like other keys,
sound(800,10)
ENDCASE
ENDDO WHILE .t.
*
* display calculator
*
***************************************************************************
PROCEDURE disp_calc

parameters color1,color2
***************************************************************************

wselect(calcwind)
wuse(19,30,y,x,color2)
wframe(2)
wcolor(color1)

wframe(2,calcwind,1,2,3,27)
wprint(2,3,space(24))

wcolor(color2)
wframe(1,calcwind,4,5,6,7)
wframe(1,calcwind,4,9,6,11)
wframe(1,calcwind,4,13,6,15)
wframe(1,calcwind,4,17,6,19)
wframe(1,calcwind,4,21,6,23)

wcolor(color1)
wprint(5,6,"=")
wprint(5,10,"7")
wprint(5,14,"8")
wprint(5,18,"9")
wprint(5,22,"-")

wcolor(color2)
wframe(1,calcwind,7,5,9,7)
wframe(1,calcwind,7,9,9,11)
wframe(1,calcwind,7,13,9,15)
wframe(1,calcwind,7,17,9,19)
wframe(1,calcwind,7,21,11,23)

wcolor(color1)
wprint(8,6,"/")
wprint(8,10,"4")
wprint(8,14,"5")
wprint(8,18,"6")

wprint(8,22," ")
wprint(9,22,"+")
wprint(10,22," ")


wcolor(color2)
wframe(1,calcwind,10,5,12,7)
wframe(1,calcwind,10,9,12,11)
wframe(1,calcwind,10,13,12,15)
wframe(1,calcwind,10,17,12,19)

wcolor(color1)
wprint(11,6,"*")
wprint(11,10,"1")
wprint(11,14,"2")
wprint(11,18,"3")

wcolor(color2)
wframe(1,calcwind,13,5,15,7)
wframe(1,calcwind,13,9,15,11)
wframe(1,calcwind,13,13,15,15)


wcolor(color1)
wprint(14,6,".")
wprint(14,10,chr(27))
wprint(14,14,"0")

wcolor(color2)
wline(16,0,16,29,2,1)

wcolor(color1)
wprint(17,6,"C")
wprint(17,10,"V=+/-")

wdisplay()

RETURN

*************************************************************************
PROCEDURE mov_calc
*************************************************************************

DO CASE

CASE (c = 5) && up arrow
wshift(1,calcwind,1)
CASE (c = 24) && dwn arrow
wshift(3,calcwind,1)
CASE (c = 19) && left arrow
wshift(4,calcwind,1)
CASE (c = 4) && right arrow
wshift(2,calcwind,1)

ENDCASE

RETURN




  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : WINDOWS.ZIP
Filename : CALC.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/