Программа

module MatrixEigenComplete where

type Matrix = [[Double]]

type Vector = [Double]

epsilon :: Double

epsilon = 1e-7

safeDiv :: Double -> Double -> Double

safeDiv _ 0 = 0.0

safeDiv x y = x / y

-- Умножение векторов

dotProduct :: Vector -> Vector -> Double

dotProduct xs ys = sum $ zipWith (*) xs ys

-- Нормализация

vectorNorm :: Vector -> Double

vectorNorm v =

let normSq = dotProduct v v

in if normSq < epsilon then 0.0 else sqrt normSq

vectorNormalization :: Vector -> Vector

vectorNormalization v

| norm < epsilon = v

| otherwise = map (/ norm) v

where norm = vectorNorm v

addRows :: Vector -> Vector -> Vector

addRows = zipWith (+)

multRowNum :: Double -> Vector -> Vector

multRowNum k = map (* k)

absElem :: Double -> Double

absElem = abs

isRealZero :: Double -> Bool

isRealZero x = absElem x < epsilon

isRealsEqual :: Double -> Double -> Bool

isRealsEqual x y = isRealZero (x - y)

divReal :: Double -> Double -> Double

divReal _ 0 = 0.0

divReal x y = x / y

divVectors :: Vector -> Vector -> Vector

divVectors = zipWith divReal

-- Извлечение элемента

extractRowElement :: Int -> Vector -> Double

extractRowElement i row = row !! i

extractMatrixElement :: Int -> Int -> Matrix -> Double

extractMatrixElement row col matrix = extractRowElement col (matrix !! row)

extractRow :: Int -> Matrix -> Vector

extractRow i matrix = matrix !! i

modRowInMatrix :: Int -> Matrix -> Int -> Vector -> Matrix

modRowInMatrix _ matrix 0 newRow = newRow : tail matrix

modRowInMatrix n matrix rowIndex newRow =

take rowIndex matrix ++ [newRow] ++ drop (rowIndex + 1) matrix

exchangeRowsInMatrix :: Int -> Matrix -> Int -> Int -> Matrix

exchangeRowsInMatrix _ matrix r1 r2

| r1 == r2 = matrix

| otherwise =

let row1 = extractRow r1 matrix

row2 = extractRow r2 matrix

in modRowInMatrix (length matrix) (modRowInMatrix (length matrix) matrix r1 row2) r2 row1

-- Транспонирование матрицы

transposeMatrix :: Matrix -> Matrix

transposeMatrix [] = []

transposeMatrix ([]:_) = []

transposeMatrix m = map head m : transposeMatrix (map tail m)

-- Умножение матриц

multMatrixElem :: Int -> Int -> Matrix -> Matrix -> Double

multMatrixElem i j a b = dotProduct (extractRow i a) [extractMatrixElement k j b | k <- [0..length a - 1]]

multMatrixRow :: Matrix -> Matrix -> Int -> Vector

multMatrixRow a b rowIndex = [multMatrixElem rowIndex j a b | j <- [0..length (head b) - 1]]

multMatrix :: Matrix -> Matrix -> Matrix

multMatrix a b = [multMatrixRow a b i | i <- [0..length a - 1]]

eyeMatrix :: Int -> Int -> Matrix

eyeMatrix n cols = [[if i == j then 1.0 else 0.0 | j <- [0..cols-1]] | i <- [0..n-1]]

-- Алгоритм Гаусса-Жордана

findMaxAbsInColumn :: Int -> Matrix -> Int -> Int

findMaxAbsInColumn n matrix col =

snd $ maximum [(absElem (extractMatrixElement row col matrix), row) | row <- [col..n-1]]

eliminateColumn :: Int -> Matrix -> Matrix -> Int -> Int -> (Matrix, Matrix)

eliminateColumn n a b col row

| row >= n = (a, b)

| row == col = eliminateColumn n a b col (row + 1)

| otherwise =

let element = extractMatrixElement row col a

colRowA = multRowNum (-element) (extractRow col a)

colRowB = multRowNum (-element) (extractRow col b)

rowA = extractRow row a

rowB = extractRow row b

newRowA = addRows rowA colRowA

newRowB = addRows rowB colRowB

aNew = modRowInMatrix n a row newRowA

bNew = modRowInMatrix n b row newRowB

in eliminateColumn n aNew bNew col (row + 1)

invGaussIterDiv :: Int -> Matrix -> Matrix -> Int -> (Matrix, Matrix)

invGaussIterDiv n a b rowIndex =

let pivot = extractMatrixElement rowIndex rowIndex a

in if isRealZero pivot

then error "Matrix is singular - no inverse exists"

else

let scale = safeDiv 1.0 pivot

pivotRowA = multRowNum scale (extractRow rowIndex a)

pivotRowB = multRowNum scale (extractRow rowIndex b)

aScaled = modRowInMatrix n a rowIndex pivotRowA

bScaled = modRowInMatrix n b rowIndex pivotRowB

in eliminateColumn n aScaled bScaled rowIndex 0

invGaussIter :: Int -> Matrix -> Matrix -> Matrix -> Matrix -> Int -> (Matrix, Matrix)

invGaussIter n a b aResult bResult row

| row >= n = (aResult, bResult)

| otherwise =

let maxRow = findMaxAbsInColumn n a row

aSwapped = exchangeRowsInMatrix n a row maxRow

bSwapped = exchangeRowsInMatrix n b row maxRow

(aDiv, bDiv) = invGaussIterDiv n aSwapped bSwapped row

in invGaussIter n aDiv bDiv aDiv bDiv (row + 1)

invGauss :: Int -> Matrix -> Matrix

invGauss n a = snd $ invGaussIter n a (eyeMatrix n n) a (eyeMatrix n n) 0

inv :: Int -> Matrix -> Matrix

inv n a = invGauss n a

-- Собственные векторы

data EigenResult = EigenResult { eigenvectors :: [Vector], eigenvals :: [Double], iterations :: Int }

minElementOfVector :: Vector -> Double

minElementOfVector = minimum

maxElementOfVector :: Vector -> Double

maxElementOfVector = maximum

isEigenvectorStable :: Vector -> Vector -> Bool

isEigenvectorStable x ax =

let divs = divVectors ax x

minDiv = minElementOfVector divs

maxDiv = maxElementOfVector divs

in maxDiv - minDiv < 1e-6

isEigenvectorsStable :: [Vector] -> [Vector] -> Bool

isEigenvectorsStable [] [] = True

isEigenvectorsStable (x:xs) (ax:axs) = isEigenvectorStable x ax && isEigenvectorsStable xs axs

isEigenvectorsStable _ _ = False

calcEigenvalue :: Vector -> Vector -> Double

calcEigenvalue x ax =

let divs = divVectors ax x

in safeDiv (minimum divs + maximum divs) 2.0

calcEigenvalues :: [Vector] -> [Vector] -> [Double]

calcEigenvalues xs axs = [calcEigenvalue x ax | (x, ax) <- zip xs axs]

--Удаление компоненты

removeComponent :: Vector -> Vector -> Vector

removeComponent v1 v2 =

let prod = dotProduct v1 v2

norm2 = dotProduct v2 v2

projCoeff = safeDiv prod norm2

proj = multRowNum projCoeff v2

in addRows v1 (multRowNum (-1.0) proj)

--Удаление компоненты из векторов

removeComponentFromVectors :: [Vector] -> Vector -> [Vector]

removeComponentFromVectors [] _ = []

removeComponentFromVectors (v:vs) normV =

let v1 = removeComponent v normV

normalized = vectorNormalization v1

in normalized : removeComponentFromVectors vs normV

--Функция вызова алгоритма Грамма-Шмидта

grammSchmidt :: [Vector] -> [Vector]

grammSchmidt [] = []

grammSchmidt (v:vs) =

let normV = vectorNormalization v

in normV : grammSchmidt (removeComponentFromVectors vs normV)

processCandidates :: Int -> Int -> Matrix -> [Vector] -> [Vector]

processCandidates n k m x =

let tx = transposeMatrix x

tmx = multMatrix m tx

in transposeMatrix tmx

generateBetterInitialVectors :: Int -> [Vector]

generateBetterInitialVectors n =

let base = replicate n 1.0

vectors = map (\i -> replicate i 0.0 ++ [1.0] ++ replicate (n-i-1) 0.1) [0..n-1]

in map vectorNormalization vectors

-- Итерации

findEigenvectorsLimited :: Int -> Int -> Matrix -> [Vector] -> Int -> EigenResult

findEigenvectorsLimited n k m currentX iter

| iter > 3000 =

let mx = processCandidates n k m currentX

in EigenResult currentX (calcEigenvalues currentX mx) iter

| otherwise =

let mx = processCandidates n k m currentX

in if isEigenvectorsStable currentX mx

then EigenResult currentX (calcEigenvalues currentX mx) iter

else findEigenvectorsLimited n k m (grammSchmidt mx) (iter + 1)

findEigenvectors :: Int -> Int -> Matrix -> [Vector] -> EigenResult

findEigenvectors n k m x = findEigenvectorsLimited n k m x 0

-- Симметрия матрицы

isMatrixSymmetric :: Int -> Int -> Matrix -> Bool

isMatrixSymmetric _ _ m = m == transposeMatrix m

-- Проверка размеров матриц

checkDimensions :: Int -> Int -> Int -> Int -> Int -> Either String ()

checkDimensions aRows aCols bRows bCols k

| aRows /= aCols = Left "Matrix A is not square"

| bRows /= bCols = Left "Matrix B is not square"

| aRows /= bRows = Left "Matrix A and B have different dimensions"

| k > aRows = Left $ "To find " ++ show k ++ " eigenvalues, matrix dimension must be >= " ++ show k

| otherwise = Right ()

prettyPrintMatrix :: Matrix -> String

prettyPrintMatrix m = unlines $ map (unwords . map show) m

-- Чтение матрицы

readMatrixFromFile :: FilePath -> IO Matrix

readMatrixFromFile filePath = do

contents <- readFile filePath

return $ map (map read . words) (lines contents)

-- Main

main :: IO ()

main = do

matrixA <- readMatrixFromFile "A.txt"

matrixB <- readMatrixFromFile "B.txt"

let n = length matrixA

k = n

dimCheck = checkDimensions (length matrixA) (length $ head matrixA)

(length matrixB) (length $ head matrixB) k

case dimCheck of

Left err -> putStrLn $ "Error: " ++ err

Right _ -> do

putStrLn "=== Matrix Eigenvalue Problem Solver ==="

putStrLn "Matrix A:"

putStrLn $ prettyPrintMatrix matrixA

putStrLn "Matrix B:"

putStrLn $ prettyPrintMatrix matrixB

let invB = inv n matrixB

m = multMatrix invB matrixA

symmetric = isMatrixSymmetric n n m

putStrLn "Matrix M = inv(B) * A:"

putStrLn $ prettyPrintMatrix m

putStrLn $ "Is M symmetric: " ++ show symmetric

if not symmetric

then putStrLn "Warning: Matrix M is not symmetric!"

else do

let isAllOnes = all (all (\x -> isRealsEqual x 1.0)) m

initialVectors = if isAllOnes

then generateBetterInitialVectors n

else transposeMatrix (eyeMatrix n k)

result = findEigenvectors n k m initialVectors

let evecs = eigenvectors result

evals = eigenvals result

iters = iterations result

if iters > 3000

then putStrLn "WARNING: Maximum iterations reached!"

else putStrLn "Successfully converged!"

putStrLn $ "Found " ++ show k ++ " eigenvalues: " ++ show evals