Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Rechenknecht v1a1
| Uploader: |  OneCypher |
| Datum/Zeit: | 04.10.2008 20:34:02 |
'Copyright by Christian H. alias OneCypher
'Diesen Quelltext stelle ich ausschließlich für nichtkommerzielle Zwecke zur Verfügung.
'Änderungen und Erweiterungen müssen mit Hinweis auf den Urheber und einschränkungen des Verwendungszwecks veröffentlich werden!
'Der Programmname "Rechenknecht" ist vorläufig und stellt keinen markenrechtlichen Besitzanspruch seitens des Urhebers dar!
'BITTE ZUERST LESEN:::::
'Tastenbelegung:
'1 : Einfache Ergebnisanzeige (nur 1. Eingang wird dargestellt)
'2 : Wert-Eingabefeld (Ein Baustein das am ehesten einer Konstanten gleichkommt)
'3 : + (Alle Eingänge werden addiert)
'4 : - (Alle Eingänge ab dem 2. werden vom 1. Eingang subtrahirt)
'5 : * (Alle Eingänge werden miteinander multipliziert)
'6 : / (1. Eingang wird durch 2. dividiert, das ergebnis daraus wird durch den 3. dividiert, usw...)
'7 : SQR (Alle Eingänge werden addiert und dann die Wurzel aus dem Ergebnis gezogen)
'8 : 1/x (1 wird durch die addition aller Eingänge dividiert)
'DIGITALTECHNIK:
'9 : UND
'0 : ODER
'i : INVERTER
'andere Tastenfunktionen:
'a : Erstellt einen neuen Baustein (default = Werteingabefeld)
's : Stop/Start
'(Anfangszustand des Programms ist gestoppt, soll das Programm anfangen zu rechnen, dann bitte die "s" Taste drücken!)
'v = Weisst einem Baustein einen Wert zu. (Sinnvoll eigentlich nur bei Werteingabefelder (Taste 2))
'f = dreht den Baustein von links auf rechts
dim shared rsizex as integer = 100
dim shared rsizey as integer = 100
dim shared aside as ubyte = 1
dim shared oside as ubyte = 2
open cons for output as #1
type _in
in as any ptr 'eigentlich _rk
nx_in as _in ptr
end type
type _rk
i as _in ptr
li as _in ptr
o(1 to 2) as double
rtype as integer
nx_rk as _rk ptr
x as integer
y as integer
flipped as ubyte '0 = Eingänge links, Ausgänge rechts. 1 = umgekehrt
declare sub show() 'Rechenknecht zeichnen
declare sub calc() 'Rechnen!
end type
sub _rk.show()
dim ic as integer
dim c as string
dim oc as string
dim target as _rk ptr
dim inputs as _in ptr
oc = "" & o(oside)
select case rtype
case -1
c = "="
case 0
c = "#"
case 1
c = "+"
case 2
c = "-"
case 3
c = "*"
case 4
c = "/"
case 5
c = "SQR"
case 6
c = "1/x"
case 7
c = "UND"
case 8
c = "ODER"
case 9
c = "INVERT"
end select
line(x,y)-(x+rsizex,y+rsizey),RGB(0,0,0),BF 'Einheit zeichnen
line(x,y)-(x+rsizex,y+rsizey),RGB(255,255,255),B 'Einheit zeichnen
if rtype <> 0 then
if flipped = 0 then
line(x,y)-(x+8,y+rsizey),RGB(0,255,0),BF 'Eingang zeichnen
else
line(x+rsizex-8,y)-(x+rsizex,y+rsizey),RGB(0,255,0),BF 'Eingang zeichnen
end if
end if
if flipped = 0 then
line(x+rsizex-8,y)-(x+rsizex,y+rsizey),RGB(255,255,0),BF 'Ausgang zeichnen
else
line(x,y)-(x+8,y+rsizey),RGB(255,255,0),BF 'Ausgang zeichnen
end if
DRAW STRING (x+(rsizex /2) - ((len(c)*8) /2) ,y+(rsizey /2) -7 ), c
DRAW STRING (x+(rsizex /2) - ((len(oc) * 8) /2) ,y+(rsizey /2) +7 ), oc
if i <> 0 then
inputs = i
ic = 0
while inputs <> 0
target = inputs->in
ic += 1
if flipped = 0 then
if target->flipped = 0 then
line(target->x + rsizex - 4,target->y + (rsizey /2))-(x+4,y+(ic *16)),RGB(0,255,255)
else
line(target->x+4,target->y+(rsizey /2))-(x+4,y+(ic *16)),RGB(0,255,255)
end if
else
if target->flipped = 0 then
line(target->x + rsizex - 4,target->y + (rsizey /2))-(x+rsizex -4,y+(ic *16)),RGB(0,255,255)
else
line(target->x+4,target->y+(rsizey /2))-(x+rsizex -4,y+(ic *16)),RGB(0,255,255)
end if
end if
inputs = inputs->nx_in
wend
end if
end sub
sub _rk.calc()
dim ark as _in ptr
dim target as _rk ptr
dim nin as _in ptr
dim inited as ubyte = 0
dim ic as integer 'Input Zähler
if i <> 0 then
ark = i
if rtype <> 0 then o(oside) = 0
while ark <> 0
target = ark->in
nin = ark->nx_in
if inited = 0 and rtype <> 0 and rtype <> 5 and rtype <> 6 and rtype <> 7 and rtype <> 8 and rtype <> 9 then
o(oside) = target->o(aside)
inited = 1
else
select case rtype
case -1
'Nur anzeige
case 0
'Speicher / nix tun
case 1
o(oside) += target->o(aside)
case 2
o(oside) -= target->o(aside)
case 3
o(oside) *= target->o(aside)
case 4
o(oside) /= target->o(aside)
case 5
'Wurzel
o(oside) += target->o(aside)
if nin = 0 then o(oside) = sqr(o(oside))
case 6
'1/x
o(oside) += target->o(aside)
if nin = 0 then o(oside) = 1 / o(oside)
case 7
'UND
if target->o(aside) <> 0 then o(oside) += 1
ic += 1
if nin = 0 then
if ic = o(oside) then
o(oside) = 1
else
o(oside) = 0
end if
end if
case 8
'ODER
o(oside) += target->o(aside)
if nin = 0 then
if o(oside)<> 0 then
o(oside) = 1
else
o(oside) = 0
end if
end if
case 9
'INVERTIERER
o(oside) += target->o(aside)
if nin = 0 then
if o(oside) = 0 then
o(oside) = 1
else
o(oside) = 0
end if
end if
end select
end if
ark = ark->nx_in
wend
end if
end sub
dim shared rlist as _rk ptr
function getlength(x1 as integer,y1 as integer,x2 as integer,y2 as integer) as double
return sqr((x2-x1)*(x2-x1) + (y2-y1)*(y2-y1))
end function
function getnearest(x as integer,y as integer) as _rk ptr
dim alist as _rk ptr
dim tlist as _rk ptr
dim l as double
dim ll as double
alist = rlist
ll = 10000
while alist <> 0
l = getlength(alist->x+(rsizex /2),alist->y+(rsizey /2),x,y)
if l < ll then
ll = l
tlist = alist
end if
alist = alist->nx_rk
wend
return tlist
end function
sub changetype(x as integer,y as integer,rtype as integer)
dim tlist as _rk ptr = getnearest(x,y)
if tlist <> 0 then
tlist->rtype = rtype
end if
end sub
sub changevalue(x as integer,y as integer,v as double)
dim tlist as _rk ptr = getnearest(x,y)
if tlist <> 0 then
tlist->o(1) = v
tlist->o(2) = v
end if
end sub
sub changeside
if aside = 1 then
aside = 2
oside = 1
else
aside = 1
oside = 2
end if
end sub
screen 18,32,2,0
dim in as string
dim alist as _rk ptr
dim llist as _rk ptr
dim mx as integer, my as integer, btn as integer
dim tx as integer, ty as integer
dim tx1 as integer, ty1 as integer
dim s as ubyte = 1
dim v as double
dim connect1 as _rk ptr
dim connect2 as _rk ptr
do
in = inkey
getmouse mx,my,,btn
if alist > 0 then
if s = 0 then alist->calc()
alist->show()
alist = alist->nx_rk
if alist = 0 then
screenunlock
pcopy 0,1
screenlock
cls
if s = 0 then changeside
alist = rlist
end if
end if
select case in
case "a"
if rlist = 0 then
rlist = new _rk
alist = rlist
llist = rlist
llist->x = mx
llist->y = my
llist->rtype = 0
else
llist->nx_rk = new _rk
llist = llist->nx_rk
llist->x = mx
llist->y = my
llist->rtype = 0
end if
case "s"
if s = 1 then
s = 0
else
s = 1
end if
case "f"
connect1 = getnearest(mx,my)
if connect1 <> 0 then
if connect1->flipped = 1 then
connect1->flipped = 0
else
connect1->flipped = 1
end if
end if
case "1"
changetype mx,my,-1
case "2"
changetype mx,my,0
case "3"
changetype mx,my,1
case "4"
changetype mx,my,2
case "5"
changetype mx,my,3
case "6"
changetype mx,my,4
case "7"
changetype mx,my,5
case "8"
changetype mx,my,6
case "9"
changetype mx,my,7
case "0"
changetype mx,my,8
case "i"
changetype mx,my,9
case "v"
screenunlock
locate 5,1:input "value:",v
changevalue mx,my,v
screenlock
end select
if btn = 1 then
pcopy 1,0
screenunlock
connect1 = getnearest(mx,my)
line(connect1->x-1,connect1->y-1)-(connect1->x+rsizex+1,connect1->y+rsizey+1),RGB(255,0,0),B
do
getmouse mx,my,,btn
if mx <> tx or my <> ty then
screenlock
pcopy 1,0
if connect1->flipped = 0 then
line (connect1->x+rsizex -3,connect1->y+(rsizey /2))-(mx-1,my),RGB(128,128,255)
line (connect1->x+rsizex -4,connect1->y+(rsizey /2))-(mx,my),RGB(128,128,255)
line (connect1->x+rsizex -5,connect1->y+(rsizey /2))-(mx+1,my),RGB(128,128,255)
else
line (connect1->x+3,connect1->y+(rsizey /2))-(mx-1,my),RGB(128,128,255)
line (connect1->x+4,connect1->y+(rsizey /2))-(mx,my),RGB(128,128,255)
line (connect1->x+5,connect1->y+(rsizey /2))-(mx+1,my),RGB(128,128,255)
end if
tx = mx: ty = my
screenunlock
end if
loop until btn = 0
connect2 = getnearest(mx,my)
if connect1 <> connect2 then
if connect2->i = 0 then
connect2->i = new _in
connect2->li = connect2->i
connect2->li->in = connect1
else
connect2->li->nx_in = new _in
connect2->li = connect2->li->nx_in
connect2->li->in = connect1
end if
end if
screenlock
end if
if btn = 2 then
pcopy 1,0
screenunlock
connect1 = getnearest(mx,my)
if connect1 <> 0 then
tx = mx: ty = my
tx1 = mx - connect1->x
ty1 = my - connect1->y
do
btn = 0
getmouse mx,my,,btn
in = inkey
if mx <> tx or my <> ty then
screenlock
pcopy 1,0
line (mx- tx1,my-ty1)-(mx + rsizex-tx1,my+rsizey-ty1),RGB(255,255,0),BF
tx = mx: ty = my
screenunlock
end if
loop until btn = 0 or in = "m"
connect1->x = (mx-tx1)
connect1->y = (my-ty1)
end if
end if
loop until in = "q"
screenunlock