2016 Update
This commit is contained in:
Tina Müller
parent
948b86eafa
commit
dcf5d15da3
7965 changed files with 139854 additions and 31002 deletions
|
|
@ -0,0 +1,17 @@
|
|||
(defmacro mapcar-1 (fn n list)
|
||||
"Maps a function of two parameters where the first one is fixed, over a list"
|
||||
`(mapcar #'(lambda (l) (funcall ,fn ,n l)) ,list) )
|
||||
|
||||
|
||||
(defun gauss (m)
|
||||
(labels
|
||||
((redc (m) ; Reduce to triangular form
|
||||
(if (null (cdr m))
|
||||
m
|
||||
(cons (car m) (mapcar-1 #'cons 0 (redc (mapcar #'cdr (mapcar #'(lambda (r) (mapcar #'- (mapcar-1 #'* (caar m) r)
|
||||
(mapcar-1 #'* (car r) (car m)))) (cdr m)))))) ))
|
||||
(rev (m) ; Reverse each row except the last element
|
||||
(reverse (mapcar #'(lambda (r) (append (reverse (butlast r)) (last r))) m)) ))
|
||||
(catch 'result
|
||||
(let ((m1 (redc (rev (redc m)))))
|
||||
(reverse (mapcar #'(lambda (r) (let ((pivot (find-if-not #'zerop r))) (if pivot (/ (car (last r)) pivot) (throw 'result 'singular)))) m1)) ))))
|
||||
110
Task/Gaussian-elimination/Haskell/gaussian-elimination-1.hs
Normal file
110
Task/Gaussian-elimination/Haskell/gaussian-elimination-1.hs
Normal file
|
|
@ -0,0 +1,110 @@
|
|||
foldlZipWith::(a -> b -> c) -> (d -> c -> d) -> d -> [a] -> [b] -> d
|
||||
foldlZipWith _ _ u [] _ = u
|
||||
foldlZipWith _ _ u _ [] = u
|
||||
foldlZipWith f g u (x:xs) (y:ys) = foldlZipWith f g (g u (f x y)) xs ys
|
||||
|
||||
foldl1ZipWith::(a -> b -> c) -> (c -> c -> c) -> [a] -> [b] -> c
|
||||
foldl1ZipWith _ _ [] _ = error "First list is empty"
|
||||
foldl1ZipWith _ _ _ [] = error "Second list is empty"
|
||||
foldl1ZipWith f g (x:xs) (y:ys) = foldlZipWith f g (f x y) xs ys
|
||||
|
||||
multAdd::(a -> b -> c) -> (c -> c -> c) -> [[a]] -> [[b]] -> [[c]]
|
||||
multAdd f g xs ys = map (\us -> foldl1ZipWith (\u vs -> map (f u) vs) (zipWith g) us ys) xs
|
||||
|
||||
mult:: Num a => [[a]] -> [[a]] -> [[a]]
|
||||
mult xs ys = multAdd (*) (+) xs ys
|
||||
|
||||
bubble::([a] -> c) -> (c -> c -> Bool) -> [[a]] -> [[b]] -> ([[a]],[[b]])
|
||||
bubble _ _ [] ts = ([],ts)
|
||||
bubble _ _ rs [] = (rs,[])
|
||||
bubble f g (r:rs) (t:ts) = bub r t (f r) rs ts [] []
|
||||
where
|
||||
bub l k _ [] _ xs ys = (l:xs,k:ys)
|
||||
bub l k _ _ [] xs ys = (l:xs,k:ys)
|
||||
bub l k m (u:us) (v:vs) xs ys = ans
|
||||
where
|
||||
mu = f u
|
||||
ans | g m mu = bub l k m us vs (u:xs) (v:ys)
|
||||
| otherwise = bub u v mu us vs (l:xs) (k:ys)
|
||||
|
||||
pivot::Num a => [a] -> [a] -> [[a]] -> [[a]] -> ([[a]],[[a]])
|
||||
pivot xs ks ys ls = go ys ls [] []
|
||||
where
|
||||
x = head xs
|
||||
fun r = zipWith (\u v -> u*r - v*x)
|
||||
val rs ts = let f = fun (head rs) in (tail $ f xs rs,f ks ts)
|
||||
go [] _ us vs = (us,vs)
|
||||
go _ [] us vs = (us,vs)
|
||||
go rs ts us vs = go (tail rs) (tail ts) (es:us) (fs:vs)
|
||||
where (es,fs) = val (head rs) (head ts)
|
||||
|
||||
triangle::(Num a,Ord a) => [[a]] -> [[a]] -> ([[a]],[[a]])
|
||||
triangle as bs = go (as,bs) [] []
|
||||
where
|
||||
go ([],_) us vs = (us,vs)
|
||||
go (_,[]) us vs = (us,vs)
|
||||
go (rs,ts) us vs = ans
|
||||
where
|
||||
(xs:ys,ks:ls) = bubble (abs.head) (>=) rs ts
|
||||
ans = go (pivot xs ks ys ls) (xs:us) (ks:vs)
|
||||
|
||||
solveTriangle::(Fractional a,Eq a) => [[a]] -> [[a]] -> [[a]]
|
||||
solveTriangle [] _ = []
|
||||
solveTriangle _ [] = []
|
||||
solveTriangle as _ | not.null.dropWhile ((/= 0).head) $ as = []
|
||||
solveTriangle ([c]:as) (b:bs) = go as bs [map (/c) b]
|
||||
where
|
||||
val us vs ws = let u = head us in map (/u) $ zipWith (-) vs (head $ mult [tail us] ws)
|
||||
go [] _ zs = zs
|
||||
go _ [] zs = zs
|
||||
go (x:xs) (y:ys) zs = go xs ys $ (val x y zs):zs
|
||||
|
||||
solveGauss:: (Fractional a, Ord a) => [[a]] -> [[a]] -> [[a]]
|
||||
solveGauss as bs = uncurry solveTriangle $ triangle as bs
|
||||
|
||||
matI::(Num a) => Int -> [[a]]
|
||||
matI n = [ [fromIntegral.fromEnum $ i == j | j <- [1..n]] | i <- [1..n]]
|
||||
|
||||
task::[[Rational]] -> [[Rational]] -> IO()
|
||||
task a b = do
|
||||
let x = solveGauss a b
|
||||
let u = map (map fromRational) x
|
||||
let y = mult a x
|
||||
let identity = matI (length x)
|
||||
let a1 = solveGauss a identity
|
||||
let h = mult a a1
|
||||
let z = mult a1 b
|
||||
putStrLn "a ="
|
||||
mapM_ print a
|
||||
putStrLn "b ="
|
||||
mapM_ print b
|
||||
putStrLn "solve: a * x = b => x = solveGauss a b ="
|
||||
mapM_ print x
|
||||
putStrLn "u = fromRationaltoDouble x ="
|
||||
mapM_ print u
|
||||
putStrLn "verification: y = a * x = mult a x ="
|
||||
mapM_ print y
|
||||
putStrLn $ "test: y == b = "
|
||||
print $ y == b
|
||||
putStrLn "identity matrix: identity ="
|
||||
mapM_ print identity
|
||||
putStrLn "find: a1 = inv(a) => solve: a * a1 = identity => a1 = solveGauss a identity ="
|
||||
mapM_ print a1
|
||||
putStrLn "verification: h = a * a1 = mult a a1 ="
|
||||
mapM_ print h
|
||||
putStrLn $ "test: h == identity = "
|
||||
print $ h == identity
|
||||
putStrLn "z = a1 * b = mult a1 b ="
|
||||
mapM_ print z
|
||||
putStrLn "test: z == x ="
|
||||
print $ z == x
|
||||
|
||||
main = do
|
||||
let a = [[1.00, 0.00, 0.00, 0.00, 0.00, 0.00],
|
||||
[1.00, 0.63, 0.39, 0.25, 0.16, 0.10],
|
||||
[1.00, 1.26, 1.58, 1.98, 2.49, 3.13],
|
||||
[1.00, 1.88, 3.55, 6.70, 12.62, 23.80],
|
||||
[1.00, 2.51, 6.32, 15.88, 39.90, 100.28],
|
||||
[1.00, 3.14, 9.87, 31.01, 97.41, 306.02]]
|
||||
let b = [[-0.01], [0.61], [0.91], [0.99], [0.60], [0.02]]
|
||||
task a b
|
||||
103
Task/Gaussian-elimination/Haskell/gaussian-elimination-2.hs
Normal file
103
Task/Gaussian-elimination/Haskell/gaussian-elimination-2.hs
Normal file
|
|
@ -0,0 +1,103 @@
|
|||
foldlZipWith::(a -> b -> c) -> (d -> c -> d) -> d -> [a] -> [b] -> d
|
||||
foldlZipWith _ _ u [] _ = u
|
||||
foldlZipWith _ _ u _ [] = u
|
||||
foldlZipWith f g u (x:xs) (y:ys) = foldlZipWith f g (g u (f x y)) xs ys
|
||||
|
||||
foldl1ZipWith::(a -> b -> c) -> (c -> c -> c) -> [a] -> [b] -> c
|
||||
foldl1ZipWith _ _ [] _ = error "First list is empty"
|
||||
foldl1ZipWith _ _ _ [] = error "Second list is empty"
|
||||
foldl1ZipWith f g (x:xs) (y:ys) = foldlZipWith f g (f x y) xs ys
|
||||
|
||||
multAdd::(a -> b -> c) -> (c -> c -> c) -> [[a]] -> [[b]] -> [[c]]
|
||||
multAdd f g xs ys = map (\us -> foldl1ZipWith (\u vs -> map (f u) vs) (zipWith g) us ys) xs
|
||||
|
||||
mult:: Num a => [[a]] -> [[a]] -> [[a]]
|
||||
mult xs ys = multAdd (*) (+) xs ys
|
||||
|
||||
triangle::(Fractional a, Ord a) => [[a]] -> [[a]] -> (a,[(([a],[a]),Int)])
|
||||
triangle as bs = pivot 1 [] $ zipWith3 (\x y i -> ((x,y),i)) as bs [(0::Int)..]
|
||||
where
|
||||
good rs ts = (abs.head.fst.fst $ ts) <= (abs.head.fst.fst $ rs)
|
||||
go (us,vs) ((os,ps),i) = if o == 0 then ((rs,f vs ps),i) else ((f us rs,f vs ps),i)
|
||||
where
|
||||
(o,rs) = (head os,tail os)
|
||||
f = zipWith (\x y -> y - x*o)
|
||||
change i (ys:zs) = map (\xs -> if (==i).snd $ xs then ys else xs) zs
|
||||
pivot d ls [] = (d,ls)
|
||||
pivot d ls zs@((_,j):ys) = if u == 0 then (0,ls) else pivot e (ps:ls) ws
|
||||
where
|
||||
e = if i == j then u*d else -u*d
|
||||
ws = map (go (map (/u) us,map (/u) vs)) $ if i == j then ys else change i zs
|
||||
ps@((u:us,vs),i) = foldl1 (\rs ts -> if good rs ts then rs else ts) zs
|
||||
|
||||
-- ((det,sol),permutation) = gauss as bs
|
||||
-- det = determinant as
|
||||
-- sol is solution of: as * sol = bs
|
||||
-- perm is a permutation with: (matPerm perm) * as * sol = (matPerm perm) * bs
|
||||
gauss::(Fractional a,Ord a) => [[a]] -> [[a]] -> ((a,[[a]]),[Int])
|
||||
gauss as bs = if 0 == det then ((0,[]),[]) else solveTriangle ms
|
||||
where
|
||||
(det,ms) = triangle as bs
|
||||
solveTriangle ((([c],b),i):sys) = go sys [map (/c) b] [i]
|
||||
where
|
||||
val us vs ws = let u = head us in map (/u) $ zipWith (-) vs (head $ mult [tail us] ws)
|
||||
go [] zs is = ((det,zs),is)
|
||||
go (((x,y),i):sys) zs is = go sys ((val x y zs):zs) (i:is)
|
||||
|
||||
solveGauss::(Fractional a,Ord a) => [[a]] -> [[a]] -> [[a]]
|
||||
solveGauss as = snd.fst.gauss as
|
||||
|
||||
matI::Num a => Int -> [[a]]
|
||||
matI n = [ [fromIntegral.fromEnum $ i == j | i <- [1..n]] | j <- [1..n]]
|
||||
|
||||
matPerm::Num a => [Int] -> [[a]]
|
||||
matPerm ns = [ [fromIntegral.fromEnum $ i == j | (j,_) <- zip [0..] ns] | i <- ns]
|
||||
|
||||
task::[[Rational]] -> [[Rational]] -> IO()
|
||||
task a b = do
|
||||
let ((d,x),perm) = gauss a b
|
||||
let ps = matPerm perm
|
||||
let u = map (map fromRational) x
|
||||
let y = mult a x
|
||||
let identity = matI (length x)
|
||||
let a1 = solveGauss a identity
|
||||
let h = mult a a1
|
||||
let z = mult a1 b
|
||||
putStrLn "d = determinant a ="
|
||||
print d
|
||||
putStrLn "a ="
|
||||
mapM_ print a
|
||||
putStrLn "b ="
|
||||
mapM_ print b
|
||||
putStrLn "solve: a * x = b => x = solveGauss a b ="
|
||||
mapM_ print x
|
||||
putStrLn "u = fromRationaltoDouble x ="
|
||||
mapM_ print u
|
||||
putStrLn "verification: y = a * x = mult a x ="
|
||||
mapM_ print y
|
||||
putStrLn $ "test: y == b = "
|
||||
print $ y == b
|
||||
putStrLn "ps is the permutation associated to matrix a and ps ="
|
||||
mapM_ print ps
|
||||
putStrLn "identity matrix: identity ="
|
||||
mapM_ print identity
|
||||
putStrLn "find: a1 = inv(a) => solve: a * a1 = identity => a1 = solveGauss a identity ="
|
||||
mapM_ print a1
|
||||
putStrLn "verification: h = a * a1 = mult a a1 ="
|
||||
mapM_ print h
|
||||
putStrLn $ "test: h == identity = "
|
||||
print $ h == identity
|
||||
putStrLn "z = a1 * b = mult a1 b ="
|
||||
mapM_ print z
|
||||
putStrLn "test: z == x ="
|
||||
print $ z == x
|
||||
|
||||
main = do
|
||||
let a = [[1.00, 0.00, 0.00, 0.00, 0.00, 0.00],
|
||||
[1.00, 0.63, 0.39, 0.25, 0.16, 0.10],
|
||||
[1.00, 1.26, 1.58, 1.98, 2.49, 3.13],
|
||||
[1.00, 1.88, 3.55, 6.70, 12.62, 23.80],
|
||||
[1.00, 2.51, 6.32, 15.88, 39.90, 100.28],
|
||||
[1.00, 3.14, 9.87, 31.01, 97.41, 306.02]]
|
||||
let b = [[-0.01], [0.61], [0.91], [0.99], [0.60], [0.02]]
|
||||
task a b
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
function gauss($a,$b) {
|
||||
$n = $a.count
|
||||
for ($k = 0; $k -lt $n; $k++) {
|
||||
$lmax, $max = $k, [Math]::Abs($a[$k][$k])
|
||||
for ($l = $k+1; $l -lt $n; $l++) {
|
||||
$tmp = [Math]::Abs($a[$l][$k])
|
||||
if($max -lt $tmp) {
|
||||
$max, $lmax = $tmp, $l
|
||||
}
|
||||
}
|
||||
if ($k -ne $lmax) {
|
||||
$a[$k], $a[$lmax] = $a[$lmax], $a[$k]
|
||||
$b[$k], $b[$lmax] = $b[$lmax], $b[$k]
|
||||
}
|
||||
$akk = $a[$k][$k]
|
||||
for ($i = $k+1; $i -lt $n; $i++){
|
||||
$aik = $a[$i][$k]
|
||||
for ($j = $k; $j -lt $n; $j++) {
|
||||
$a[$i][$j] = $a[$i][$j]*$akk - $a[$k][$j]*$aik
|
||||
}
|
||||
$b[$i] = $b[$i]*$akk - $b[$k]*$aik
|
||||
}
|
||||
}
|
||||
for ($i = $n-1; $i -ge 0; $i--) {
|
||||
for ($j = $i+1; $j -lt $n; $j++) {
|
||||
$b[$i] -= $b[$j]*$a[$i][$j]
|
||||
}
|
||||
$b[$i] = $b[$i]/$a[$i][$i]
|
||||
}
|
||||
$b
|
||||
}
|
||||
function show($a) {
|
||||
if($a) {
|
||||
0..($a.Count - 1) | foreach{ if($a[$_]){"$($a[$_][0..($a[$_].count -1)])"}else{""} }
|
||||
}
|
||||
}
|
||||
$a =(
|
||||
@(1.00, 0.00, 0.00, 0.00, 0.00, 0.00),
|
||||
@(1.00, 0.63, 0.39, 0.25, 0.16, 0.10),
|
||||
@(1.00, 1.26, 1.58, 1.98, 2.49, 3.13),
|
||||
@(1.00, 1.88, 3.55, 6.70, 12.62, 23.80),
|
||||
@(1.00, 2.51, 6.32, 15.88, 39.90, 100.28),
|
||||
@(1.00, 3.14, 9.87, 31.01, 97.41, 306.02)
|
||||
)
|
||||
"a ="
|
||||
show $a
|
||||
""
|
||||
$b = @(-0.01, 0.61, 0.91, 0.99, 0.60, 0.02)
|
||||
"b ="
|
||||
$b
|
||||
""
|
||||
"x ="
|
||||
gauss $a $b
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
function gauss-jordan($a,$b) {
|
||||
$n = $a.count
|
||||
for ($k = 0; $k -lt $n; $k++) {
|
||||
$lmax, $max = $k, [Math]::Abs($a[$k][$k])
|
||||
for ($l = $k+1; $l -lt $n; $l++) {
|
||||
$tmp = [Math]::Abs($a[$l][$k])
|
||||
if($max -lt $tmp) {
|
||||
$max, $lmax = $tmp, $l
|
||||
}
|
||||
}
|
||||
if ($k -ne $lmax) {
|
||||
$a[$k], $a[$lmax] = $a[$lmax], $a[$k]
|
||||
$b[$k], $b[$lmax] = $b[$lmax], $b[$k]
|
||||
}
|
||||
$akk = $a[$k][$k]
|
||||
for ($j = $k; $j -lt $n; $j++) {$a[$k][$j] /= $akk}
|
||||
$b[$k] /= $akk
|
||||
for ($i = 1; $i -lt $n; $i++){
|
||||
if ($i -ne $k) {
|
||||
$aik = $a[$i][$k]
|
||||
for ($j = $k; $j -lt $n; $j++) {
|
||||
$a[$i][$j] = $a[$i][$j] - $a[$k][$j]*$aik
|
||||
}
|
||||
$b[$i] = $b[$i] - $b[$k]*$aik
|
||||
}
|
||||
}
|
||||
}
|
||||
$b
|
||||
}
|
||||
function show($a) {
|
||||
if($a) {
|
||||
0..($a.Count - 1) | foreach{ if($a[$_]){"$($a[$_][0..($a[$_].count -1)])"}else{""} }
|
||||
}
|
||||
}
|
||||
$a =(
|
||||
@(1.00, 0.00, 0.00, 0.00, 0.00, 0.00),
|
||||
@(1.00, 0.63, 0.39, 0.25, 0.16, 0.10),
|
||||
@(1.00, 1.26, 1.58, 1.98, 2.49, 3.13),
|
||||
@(1.00, 1.88, 3.55, 6.70, 12.62, 23.80),
|
||||
@(1.00, 2.51, 6.32, 15.88, 39.90, 100.28),
|
||||
@(1.00, 3.14, 9.87, 31.01, 97.41, 306.02)
|
||||
)
|
||||
"a ="
|
||||
show $a
|
||||
""
|
||||
$b = @(-0.01, 0.61, 0.91, 0.99, 0.60, 0.02)
|
||||
"b ="
|
||||
$b
|
||||
""
|
||||
"x ="
|
||||
gauss-jordan $a $b
|
||||
|
|
@ -1,5 +1,14 @@
|
|||
/* REXX ---------------------------------------------------------------
|
||||
* 07.08.2014 Walter Pachl translated from PL/I)
|
||||
* improved to get integer results for, e.g. this input:
|
||||
-6 -18 13 6 -6 -15 -2 -9 -231
|
||||
2 20 9 2 16 -12 -18 -5 647
|
||||
23 18 -14 -14 -1 16 25 -17 -907
|
||||
-8 -1 -19 4 3 -14 23 8 248
|
||||
25 20 -6 15 0 -10 9 17 1316
|
||||
-13 -1 3 5 -2 17 14 -12 -1080
|
||||
19 24 -21 -5 -19 0 -24 -17 1006
|
||||
20 -3 -14 -16 -23 -25 -15 20 1496
|
||||
*--------------------------------------------------------------------*/
|
||||
Numeric Digits 20
|
||||
Parse Arg t
|
||||
|
|
@ -56,15 +65,17 @@
|
|||
Exit
|
||||
|
||||
Gauss_elimination:
|
||||
do j = 1 to n
|
||||
do i = j+1 to n /* For each of the rows beneath the current (pivot) row. */
|
||||
t = a.j.j / a.i.j
|
||||
do k = j+1 to n /* Subtract a multiple of row i from row j. */
|
||||
a.i.k = a.j.k - t*a.i.k
|
||||
end
|
||||
b.i = b.j - t*b.i /* ... and the right-hand side. */
|
||||
end
|
||||
end
|
||||
Do j=1 to n-1
|
||||
ma=a.j.j
|
||||
Do ja=j+1 To n
|
||||
mb=a.ja.j
|
||||
Do i=1 To n
|
||||
new=a.j.i*mb-a.ja.i*ma
|
||||
a.ja.i=new
|
||||
End
|
||||
b.ja=b.j*mb-b.ja*ma
|
||||
End
|
||||
End
|
||||
Return
|
||||
|
||||
Backward_substitution:
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue