Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Rechenknecht v1a4b
| Uploader: |  OneCypher |
| Datum/Zeit: | 09.10.2008 16:48:24 |
'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!
'Tastenbelegung:
'ENTER : Einfache Ergebnisanzeige (nur 1. Eingang wird dargestellt)
'0 : Wert-Eingabefeld (Ein Baustein das am ehesten einer Konstanten gleichkommt)
'+ : + (Alle Eingänge werden addiert)
'- : - (Alle Eingänge ab dem 2. werden vom 1. Eingang subtrahirt)
'* : * (Alle Eingänge werden miteinander multipliziert)
'/ : / (1. Eingang wird durch 2. dividiert, das ergebnis daraus wird durch den 3. dividiert, usw...)
'1 : SQR (Alle Eingänge werden addiert und dann die Wurzel aus dem Ergebnis gezogen)
'2 : 1/x (1 wird durch die addition aller Eingänge dividiert)
'DIGITALTECHNIK:
'3 : UND
'4 : ODER
'5 : 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!)
'PgDown : Einen Schritt weiter Rechnen (nur im gestoptten Zustand sinnvoll)
'd : Löscht einen Baustein
'v : Weisst einem Baustein einen Wert zu. (Sinnvoll eigentlich nur bei Werteingabefelder (Taste 0))
'f : dreht den Baustein von links auf rechts
'linke Maustaste : Verbindung ziehen. (Beim anklicken wird der Ausgang des Bausteins gewählt, beim loslassen wird der eingang eines anderen Bausteines gewählt)
'Zieht man zwischen 2 Bausteinen eine Verbindung obwohl dort bereits eine besteht, wird die bestehnde gelöscht!
'rechte Maustaste : Verschieben eines Bausteines
dim shared rsizex as integer = 100
dim shared rsizey as integer = 50
dim shared scrw as integer = 300
dim shared scrh as integer = 300
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 _display
scr as any ptr
w as integer
h as integer
end type
type _rk
i as _in ptr
li as _in ptr
icount as integer
o(1 to 2) as double
rtype as integer
nx_rk as _rk ptr
x as integer
y as integer
display as _display
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"
case 10
c = "SIN"
case 11
c = "COS"
case 12
case 13
end select
line(x,y)-(x+rsizex,y+rsizey),RGB(128,128,128),BF 'Einheit zeichnen
line(x,y)-(x+rsizex,y+rsizey),RGB(255,255,255),B 'Einheit zeichnen
if rtype <> 13 then
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
end if
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 * (rsizey /(icount+1)))),RGB(0,255,255)
else
line(target->x+4,target->y+(rsizey /2))-(x+4,y+(ic *(rsizey /(icount+1)))),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 *(rsizey /(icount+1)))),RGB(0,255,255)
else
line(target->x+4,target->y+(rsizey /2))-(x+rsizex -4,y+(ic *(rsizey /(icount+1)))),RGB(0,255,255)
end if
end if
inputs = inputs->nx_in
wend
icount = ic
end if
if rtype = 13 then
line (x-1,y-1)-(x+scrw+1,y+scrh+1),RGB(0,0,0),B
'put (x,y),display.scr(oside),PSET
put (x,y),display.scr,PSET
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
dim px as integer, py as integer
'icount =0
if i <> 0 then
ark = i
if rtype <> 0 then o(oside) = 0
while ark <> 0
ic +=1
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 and rtype <> 10 and rtype <> 13 abd rtyoe <> 14 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
case 10
'SINUS
o(oside) += target->o(aside)
if nin = 0 then o(oside) = sin(o(oside))
case 11
'COSINUS
o(oside) += target->o(aside)
if nin = 0 then o(oside) = cos(o(oside))
case 13
if ic = 1 then px = target->o(aside)
if ic = 2 then
py = target->o(aside)
'print px,py
pset display.scr,(px,py),RGB(255,255,255)
end if
end select
end if
ark = ark->nx_in
wend
else
if rtype <> 0 then o(oside) = 0
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
if rtype = 13 then
tlist->display.scr = imagecreate(scrw,scrh,RGB(0,0,0))
'tlist->display.scr(2) = imagecreate(scrw,scrh,RGB(0,0,0))
end if
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
function DelConnection(srk as _rk ptr, crk as _rk ptr) as ubyte
dim di as _in ptr
dim ldi as _in ptr
DelConnection = 0
if srk->i > 0 then
if srk->i = srk->li then
if srk->i->in = crk then
delete srk->i
srk->i = 0
srk->li = 0
DelConnection = 1
end if
else
di = srk->i
ldi = 0
while di <> 0
if di->in = crk then
DelConnection = 1
if ldi > 0 then
if srk->li = di then srk->li = ldi
ldi->nx_in = di->nx_in
else
if srk->i = srk->li then srk->li = 0
srk->i = srk->i->nx_in
end if
delete di
end if
ldi = di
di = di->nx_in
wend
end if
end if
end function
screen 20,32,2,0
dim sx as integer, sy as integer
screeninfo sx,sy
line(0,0)-(sx,sy),RGB(255,255,255),BF
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
dim connect3 as _rk ptr
dim stp as integer
dim i_found as ubyte
do
in = inkey
getmouse mx,my,,btn
if alist > 0 then
if s = 0 then
alist->calc()
else
if stp > 0 then alist->calc()
end if
alist->show()
alist = alist->nx_rk
if alist = 0 then
if stp > 0 then stp -= 1
screenunlock
pcopy 0,1
screenlock
line(0,0)-(sx,sy),RGB(255,255,255),BF
'cls
if s = 0 or stp > 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 "d"
connect1 = getnearest(mx,my)
if connect1 <> 0 then
connect2 = rlist
connect3 = 0
while connect2 <> 0
if connect2 <> connect1 then
i_found = DelConnection(connect2, connect1)
connect3 = connect2
connect2 = connect2->nx_rk
else
if connect3 > 0 then
connect3->nx_rk = connect2->nx_rk
delete connect2
connect2 = connect3->nx_rk
else
rlist = rlist->nx_rk
delete connect2
connect2 = rlist
end if
end if
wend
alist =rlist
llist = connect3
end if
case CHR(13)
changetype mx,my,-1
case "0"
changetype mx,my,0
case "+"
changetype mx,my,1
case "-"
changetype mx,my,2
case "*"
changetype mx,my,3
case "/"
changetype mx,my,4
case "1"
changetype mx,my,5
case "2"
changetype mx,my,6
case "3"
changetype mx,my,7
case "4"
changetype mx,my,8
case "5"
changetype mx,my,9
case "6"
changetype mx,my,10
case "7"
changetype mx,my,11
case "8"
changetype mx,my,12
case "9"
changetype mx,my,13
case "v"
pcopy 1,0
screenunlock
locate 5,1:input "value:",v
changevalue mx,my,v
screenlock
case CHR(255) & CHR(81)
stp = 2
alist = rlist
end select
if btn = 1 then
connect1 = getnearest(mx,my)
if connect1 <> 0 then
pcopy 1,0
screenunlock
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
'Wenn noch gar keine Eingangsverbindung dann erstelle eine
connect2->i = new _in
connect2->li = connect2->i
connect2->li->in = connect1
else
'Wenn schon Eingangsverbindungen vorhanden, dann prüfen ob schon existiert
if DelConnection(connect2, connect1) = 0 then
connect2->li->nx_in = new _in
connect2->li = connect2->li->nx_in
connect2->li->in = connect1
end if
end if
end if
screenlock
end if
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" or in = chr(27) or in = chr(255,107)
screenunlock