Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Rechenknecht 1
| Uploader: |  OneCypher |
| Datum/Zeit: | 04.10.2008 13:19:48 |
'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!
dim shared rsizex as integer = 200
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
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"
end select
'if len(oc) > 4 then oc = left(oc,4)
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 line(x,y)-(x+8,y+rsizey),RGB(0,255,0),BF 'Eingang zeichnen
if rtype <> -1 then line(x+rsizex-8,y)-(x+rsizex,y+rsizey),RGB(255,255,0),BF 'Ausgang zeichnen
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
line(target->x + rsizex - 3,target->y + (rsizey /2))-(x+3,y+(ic *16)),RGB(0,255,255)
line(target->x + rsizex - 4,target->y + (rsizey /2))-(x+4,y+(ic *16)),RGB(0,255,255)
line(target->x + rsizex - 5,target->y + (rsizey /2))-(x+5,y+(ic *16)),RGB(0,255,255)
line(target->x + rsizex - 3,target->y + (rsizey /2)-1)-(x+3,y+(ic *16)-1),RGB(0,255,255)
line(target->x + rsizex - 4,target->y + (rsizey /2))-(x+4,y+(ic *16)),RGB(0,255,255)
line(target->x + rsizex - 5,target->y + (rsizey /2)+1)-(x+5,y+(ic *16)+1),RGB(0,255,255)
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 t1 as double
if i <> 0 then
ark = i
'print ark
if rtype <> 0 then o(oside) = 0
while ark <> 0
target = ark->in
nin = ark->nx_in
t1 +=1': locate 20,1:print target->o(aside), t1
'print ark
if inited = 0 and rtype <> 0 and rtype <> 5 and rtype <> 6 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
' o(oside) /= target->o(aside)
'case 8
' o(oside) /= target->o(aside)
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
'print #1, "opened"
dim alist as _rk ptr
dim tlist as _rk ptr
dim l as double
dim ll as double
'dim l_rk as _rk ptr
alist = rlist
ll = 10000
'print #1, "1"
while alist <> 0
l = getlength(alist->x+(rsizex /2),alist->y+(rsizey /2),x,y)
if l < ll then
ll = l
tlist = alist
'print #1, "2 " & str(tlist)
end if
alist = alist->nx_rk
wend
'print #1, "closed " & str(tlist)
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
'print " " & tlist
'sleep 10000
end sub
sub changeside
if aside = 1 then
aside = 2
oside = 1
else
aside = 1
oside = 2
end if
end sub
screen 21,32,2,1
dim in as string
dim alist as _rk ptr
dim llist as _rk ptr
'rlist = new _rk
'rlist->rtype = 0
'rlist->o(1) = 123456
'rlist->o(2) = 123456
'rlist->x = 10
'rlist->y = 25
'Neuer rechenknecht
'rlist->nx_rk = new _rk
'alist = rlist->nx_rk
'alist->rtype = 1
'alist->x = 300
'alist->y = 25
'alist->i = new _in
'alist->i->in = rlist
'alist->i->nx_in = new _in
'alist->i->nx_in->in = rlist
'alist->i->nx_in->nx_in = new _in
'alist->i->nx_in->nx_in->in = rlist
'Neuer rechenknecht
'alist->nx_rk = new _rk
'alist = alist->nx_rk
'alist->rtype = 0
'alist->o(1) = 2
'alist->o(2) = 2
'alist->x = 10
'alist->y = 250
'Neuer rechenknecht
'alist->nx_rk = new _rk
'alist = alist->nx_rk
'alist->rtype = 4
'alist->x = 650
'alist->y = 250
'alist->i = new _in
'alist->i->in = rlist->nx_rk
'alist->i->nx_in = new _in
'alist->i->nx_in->in = rlist->nx_rk->nx_rk
'print rlist
'sleep 2000
'alist = rlist
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
'screenlock
do
in = inkey
getmouse mx,my,,btn
'print alist
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
'print alist
'sleep 10000
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 "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 "v"
screenunlock
locate 5,1:input "value:",v
changevalue mx,my,v
'sleep 1
screenlock
end select
if btn = 1 then
'print #1,"BTN1"
screenunlock
pcopy 1,0
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
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)
tx = mx: ty = my
screenunlock
end if
'sleep 1
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 <> 0 then
' print #1, "Button: " & btn
'end if
if btn = 2 then
screenunlock
'print #1,"BTN2"
connect1 = getnearest(mx,my)
'print #1,"getted " & str(connect1)
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
'sleep 100
'print #1,mx,my,btn, in
loop until btn = 0 or in = "m"
connect1->x = (mx-tx1)
connect1->y = (my-ty1)
'print #1,"BTN2-ENDE"
end if
end if
loop until in = "q"
screenunlock