Matematiikan opintojen innoittamana koodailin syksyllä tälläisen matriisin gaussaavan ohjelman. Ikävä kyllä käytin matriisin sisäisessä muodossa merkkijonoja kokonais- tai liukulukujen sijaan joten sen kummemmaksi pohjaksi tästä ei ole. Pistetään nyt jakoon kuitenkin.
Code: Select all
SCREEN 800,600
Global mh,mw
Dim matrix(2,2) As String
DefineMatrix(3,4)
EnterRow(1,"5 4 3 -33")
EnterRow(2,"6 -7 -7 103")
EnterRow(3,"4 -2 -3 43")
Repeat
If KeyHit(cbkeyspace) Then Gaussian() : SetWindow "valmis"
PrintMatrix(20,20)
DrawScreen
Forever
Function GetMultiplier(f1#,f2#)
If f1#<f2# Then
Return Max(f1#,f2#)/f1#
Else
Return 1.0
EndIf
End Function
Function FloatIsInteger(f#)
Return (Float(NiceFloatToString(f#))=f#)
EndFunction
Function Gaussian()
//echelon form
For x=1 To mw-2
While GetColumnValueAmount(x)>x
//check for matching pairs
For y=1 To mh
If x>1 Then
If matrix(y,x-1) <> "0" Then pass=1 Else pass =0
Else
pass=0
EndIf
If Not pass Then
For yy=y+1 To mh
If x>1 Then
If matrix(yy,x-1) <> "0" Then pass=1 Else pass =0
Else
pass=0
EndIf
If Not pass Then
m1# = Float(matrix(y,x))
m2# = Float(matrix(yy,x))
If m1#*m2# Then
status$=""
If m1# <> -m2# Then
mm1# = GetMultiplier(m1#,m2#)
mm2# = GetMultiplier(m2#,m1#)
If (m1#>0.0 And m2#<0.0) Or (m1#<0.0 And m2#>0.0) Then
MultipleRow(y,Abs(mm1#))
MultipleRow(yy,Abs(mm2#))
' status$ = "row "+y+" * "+Abs(mm1#)+" row "+yy+" * "+Abs(mm2#)+" "
Else
MultipleRow(y,mm1#)
MultipleRow(yy,-mm2#)
' status$ = "row "+y+" * "+mm1#+" row "+yy+" * "+-mm2#+" "
EndIf
EndIf
m1# = Float(matrix(y,x))
m2# = Float(matrix(yy,x))
If m1# = -m2# Then
If m1#>m2# Then
AddRowToRow(y,yy)
If yy<y Then SwapRows(y,yy)
' status$ = status$ + "addrow "+y+" To row "+yy
Else
AddRowToRow(yy,y)
If y<yy Then SwapRows(y,yy)
'status$ = status$ + "addrow "+yy+" To row "+y
EndIf
EndIf
EndIf
EndIf
Next yy
EndIf
Next y
Wend
Next x
//reduced echelon form
rowskip=1
While rowskip<mh' x=mh-1 And y=1
y = mh
For x=mw-1 To (1+rowskip) Step -1
m1# = Float(matrix(y,x))
m2# = Float(matrix(y-rowskip,x))
If m1#*m2# Then
'status$="bottom: "+m1#+" Upper: "+m2#
If m1# <> -m2# Then
mm1# = GetMultiplier(m1#,m2#)
mm2# = GetMultiplier(m2#,m1#)
If (m1#>0.0 And m2#<0.0) Or (m1#<0.0 And m2#>0.0) Then
MultipleRow(y,Abs(mm1#))
MultipleRow(y-rowskip,Abs(mm2#))
'status$ = status$ + " row "+y+" * "+Abs(mm1#)+" row "+yy+" * "+Abs(mm2#)+" "
Else
MultipleRow(y,mm1#)
MultipleRow(y-rowskip,-mm2#)
'status$ = status$ + " row "+y+" * "+mm1#+" row "+yy+" * "+-mm2#+" "
EndIf
EndIf
m1# = Float(matrix(y,x))
m2# = Float(matrix(y-rowskip,x))
If m1# = -m2# Then
AddRowToRow(y,y-rowskip)
' If yy<y Then SwapRows(y,yy)
' status$ = status$ + "addrow "+y+" To row "+yy
EndIf
EndIf
y=y-1
Next x
rowskip+1
Wend
For y=1 To mh
m1# = Float(matrix(y,y))
MultipleRow(y,1/m1#)
Next y
End Function
Function CorrectRoundingError(f#,precision#=0.999)
st$=Str(f#)
tail# = Float("0."+GetWord(st$,2,"."))
If tail#>precision# Then
If f#>0 Then Return Float(GetWord(st$,1,"."))+1.0 Else Return Float(GetWord(st$,1,"."))-1.0
ElseIf tail#<1.0-precision# Then
Return Float(GetWord(st$,1,"."))
Else
Return f#
EndIf
End Function
Function GetColumnValueAmount(ColNum)
i=0
For y=1 To mh
If matrix(y,ColNum) <> "0" Then i+1
Next y
Return i
End Function
Function GetLeader(RowNum)
For x=1 To mw
If matrix(RowNum,x) <> "0" Then Return matrix(RowNum,x)
Next x
Return "0"
End Function
Function MultipleRow(RowNum,mult#)
If mult# <> 0.0 Then
For x=1 To mw
matrix(RowNum,x) = NiceFloatToString(CorrectRoundingError(Float(matrix(RowNum,x))*mult#))
Next x
EndIf
End Function
Function SwapRows(RowNum1,RowNum2) //swaps row 1 with row 2
If RowNum1<>RowNum2 Then
For x=1 To mw
temp$ = matrix(RowNum2,x)
matrix(RowNum2,x) = matrix(RowNum1,x)
matrix(RowNum1,x) = temp$
Next x
EndIf
End Function
Function AddRowToRow(RowNum1,RowNum2) //adds row 1 to row 2
If RowNum1<>RowNum2 Then
For x=1 To mw
matrix(RowNum2,x) = NiceFloatToString(Float(matrix(RowNum1,x)) + Float(matrix(RowNum2,x)) )
Next x
EndIf
End Function
Function NiceFloatToString(value#)
st$=Str(value#)
If Int(GetWord(st$,2,"."))=0 Then Return GetWord(st$,1,".") Else Return st$
End Function
Function EnterRow(RowNum,row$)
For i=1 To CountWords(row$)
matrix(RowNum,i) = GetWord(row$,i)
Next i
End Function
Function PrintMatrix(xx,yy)
aw = 20
ah = 20
For x=1 To mw
For y=1 To mh
If TextWidth (matrix(y,x)) > aw Then aw = TextWidth(matrix(y,x))+5
Next y
Next x
For x=1 To mw
For y=1 To mh
Text xx+aw*(x-1),yy+ah*(y-1),matrix(y,x)
Next y
Next x
Line xx-5,yy,xx-5,yy+(y-1)*ah
Line xx+(x-1)*aw,yy,xx+(x-1)*aw,yy+(y-1)*ah
End Function
Function DefineMatrix(h,w)
mw=w
mh=h
ReDim matrix(mh,mw) As String
For x=1 To mw
For y=1 To mh
matrix(y,x) = "0"
Next y
Next x
End Function