Аппроксимация методом наименьших квадратов на базе полиномов Эрмита на Haskell

--Сортировка точек по x с использованием merge sort sortPointsByX :: [Point] -> [Point]

sortPointsByX = mergeSort

--Функция для обработки точек с одинаковыми X handleDuplicateXs :: [PointWeight] -> IO [PointWeight] handleDuplicateXs points = do

let sorted = mergeSort points

grouped = groupBy (\(x1,_,_) (x2,_,_) -> abs (x1 - x2) < 1e-9) sorted duplicates = filter (\g -> length g > 1) grouped

if null duplicates then return points else do

putStrLn "\nПРЕДУПРЕЖДЕНИЕ: Обнаружены точки с одинаковыми значениями X!" putStrLn "Группы дубликатов:"

mapM_ (\group ->

putStrLn $ " x = " ++ printf "%.6f" (let (x,_,_) = head group in x) ++ ": " ++ show (length group) ++ " точки")

duplicates

putStrLn "\nВыберите действие:" putStrLn "1. Усреднить значения Y"

putStrLn "2. Оставить точку с максимальным Y" putStrLn "3. Оставить точку с минимальным Y" putStrLn "Ваш выбор (1-3): "

choice <- getLine case choice of

"1" -> do

putStrLn "Выбрано усреднение значений Y." return $ map averageGroup grouped

"2" -> do

putStrLn "Выбрано сохранение точки с максимальным Y."

11

return $ map maxGroup grouped "3" -> do

putStrLn "Выбрано сохранение точки с минимальным Y." return $ map minGroup grouped

_ -> do

putStrLn "Неверный выбор. Автоматически применяется усреднение." return $ map averageGroup grouped

where

averageGroup :: [PointWeight] -> PointWeight averageGroup [] = error "Empty group" averageGroup grp@((x,_,_):_) =

let (totalY, totalW) = foldl' (\(sy, sw) (_, y, w) -> (sy + w*y, sw + w)) (0,0) grp in (x, totalY / totalW, totalW)

maxGroup :: [PointWeight] -> PointWeight maxGroup [] = error "Empty group" maxGroup grp =

let (x,_,_) = head grp

(_, maxY, w) = maximumBy (\(_,y1,_) (_,y2,_) -> compare y1 y2) grp in (x, maxY, w)

minGroup :: [PointWeight] -> PointWeight minGroup [] = error "Empty group" minGroup grp =

let (x,_,_) = head grp

(_, minY, w) = minimumBy (\(_,y1,_) (_,y2,_) -> compare y1 y2) grp in (x, minY, w)

-- Вспомогательная функция для сравнения (аналог maximumBy/minimumBy из Data.List) maximumBy :: (a -> a -> Ordering) -> [a] -> a

maximumBy _ [] = error "maximumBy: empty list"

maximumBy cmp xs = foldl1 (\x y -> if cmp x y == GT then x else y) xs

12

minimumBy :: (a -> a -> Ordering) -> [a] -> a minimumBy _ [] = error "minimumBy: empty list"

minimumBy cmp xs = foldl1 (\x y -> if cmp x y == LT then x else y) xs

-- Чтение и парсинг данных из файла с учетом весов parsePoint :: String -> Maybe PointWeight

parsePoint line = case words line of

(xStr:yStr:_) ->

case (reads xStr :: [(Double, String)], reads yStr :: [(Double, String)]) of ([(x, "")], [(y, "")]) -> Just (x, y, 1.0) -- начальный вес = 1.0

_ -> Nothing

_ -> Nothing

readPoints :: FilePath -> IO [PointWeight] readPoints file = do

putStrLn $ "Читаем файл: " ++ file content <- readFile file

let linesContent = lines content

validLines = filter (\l -> not (null l) && head l /= '#') linesContent maybePoints = map parsePoint validLines

points = [p | Just p <- maybePoints]

when (null points) $ putStrLn "Предупреждение: не найдено корректных точек!"

-- Удаление полных дубликатов (одинаковые x и y)

let uniquePoints = nubBy (\(x1,y1,_) (x2,y2,_) -> abs (x1 - x2) < 1e-9 && abs (y1 - y2) < 1e-9) points

putStrLn $ "Прочитано точек: " ++ show (length points)

putStrLn $ "После удаления полных дубликатов: " ++ show (length uniquePoints)

-- Обработка точек с одинаковыми X

13

processedPoints <- handleDuplicateXs uniquePoints

putStrLn $ "После обработки дубликатов по X: " ++ show (length processedPoints)

return processedPoints

-- Построение матрицы Грама и правой части СЛАУ с учетом весов buildSystem :: [PointWeight] -> Int -> (Matrix, Vector)

buildSystem points m =

let xs = [x | (x, _, _) <- points] ys = [y | (_, y, _) <- points] ws = [w | (_, _, w) <- points] n = length xs

hMatrix = [hermiteVector m x | x <- xs]

transposeH = [[hMatrix !! i !! j | i <- [0..n-1]] | j <- [0..m]]

-- Учет весов при построении матрицы Грама

gramMatrix = [[sum [ws !! k * transposeH !! i !! k * transposeH !! j !! k | k <- [0..n-1]]

| j <- [0..m]] | i <- [0..m]]

-- Учет весов при построении правой части

rightHand = [sum [ws !! k * transposeH !! i !! k * (ys !! k) | k <- [0..n-1]]

| i <- [0..m]]

in (gramMatrix, rightHand)

-- Решение СЛАУ методом Гаусса с выбором ведущего элемента gaussElimination :: Matrix -> Vector -> Vector

gaussElimination a b =

14

let n = length a

augmented = zipWith (\row bi -> row ++ [bi]) a b

forwardElim :: [[Double]] -> Int -> [[Double]] forwardElim mat k

| k == n = mat | otherwise =

let col = [mat !! i !! k | i <- [k..n-1]]

maxIdx = k + snd (maximum [(abs val, i) | (val, i) <- zip col [0..]]) mat' = if maxIdx /= k

then take k mat ++ [mat !! maxIdx] ++ [mat !! i | i <- [k..n-1], i /= maxIdx]

else mat

pivot = mat' !! k !! k

mat'' = if abs pivot < 1e-12

then error "Матрица вырождена или плохо обусловлена" else mat'

elimRow i row = if i <= k then row else

let factor = row !! k / pivot

in [row !! j - factor * (mat'' !! k !! j) | j <- [0..n]]

newRows = [if i == k then row else elimRow i row

| (i, row) <- zip [0..n-1] mat''] in forwardElim newRows (k + 1)

triangular = forwardElim augmented 0

15

backSubst :: [Double] -> Int -> [Double] backSubst sol k

| k < 0 = sol | otherwise =

let row = triangular !! k

xk = (row !! n - sum [row !! j * (sol !! j) | j <- [k+1..n-1]]) / row !! k

in backSubst (take k sol ++ [xk] ++ drop (k+1) sol) (k-1)

in backSubst (replicate n 0.0) (n-1)

-- Аппроксимация методом наименьших квадратов solveLeastSquares :: [PointWeight] -> Int -> Vector solveLeastSquares points m =

let (gramMatrix, rightHand) = buildSystem points m in gaussElimination gramMatrix rightHand

--Вычисление значения аппроксимирующего полинома в точке x evalHermitePoly :: Vector -> Double -> Double

evalHermitePoly coefs x =

sum [coefs !! k * hermite k x | k <- [0..length coefs - 1]]

--Создание равномерной сетки точек

linspace :: Int -> Double -> Double -> [Double] linspace n minX maxX

| n <= 0 = []

| n == 1 = [minX]

| otherwise = [minX + fromIntegral i * step | i <- [0..n-1]] where step = (maxX - minX) / fromIntegral (n-1)

-- Вычисление среднеквадратичной ошибки calculateRMSE :: [PointWeight] -> Vector -> Double calculateRMSE points coefs =

16

let errors = [y - evalHermitePoly coefs x | (x, y, _) <- points] squaredErrors = map (\e -> e * e) errors

mse = sum squaredErrors / fromIntegral (length points) in sqrt mse

-- ASCII-график для визуализации с правильной ориентацией (левый нижний угол = начало) asciiPlot :: [PointWeight] -> [(Double, Double)] -> IO ()

asciiPlot orig approx = do

let allX = map (\(x,_,_) -> x) orig ++ map fst approx allY = map (\(_,y,_) -> y) orig ++ map snd approx xMin = minimum allX

xMax = maximum allX yMin = minimum allY yMax = maximum allY width = 70

height = 20

-- Расширяем диапазон по Y на 10% для лучшего отображения yRange = yMax - yMin

yPadding = yRange * 0.1 yPlotMin = yMin - yPadding yPlotMax = yMax + yPadding

-- Функция для установки символа в сетке set2D grid row col c =

let newRow = take col (grid !! row) ++ [c] ++ drop (col+1) (grid !! row) in take row grid ++ [newRow] ++ drop (row+1) grid

-- Начальная сетка (пробелы)

plotGrid = replicate height (replicate width ' ')

-- Отображение исходных точек withOrig = foldl (\grid (ox, oy, _) ->

17

let col = floor $ (ox - xMin) / (xMax - xMin) * fromIntegral (width - 1)

-- ИНВЕРСИЯ: теперь меньшие значения Y будут внизу (строка с большим индексом) rowIdx = floor $ (oy - yPlotMin) / (yPlotMax - yPlotMin) * fromIntegral (height - 1)

row = rowIdx -- без инверсии: 0 - низ, height-1 - верх

in if row >= 0 && row < height && col >= 0 && col < width then set2D grid row col '*'

else grid) plotGrid orig

-- Отображение аппроксимирующей кривой finalGrid = foldl (\grid (ax, ay) ->

let col = floor $ (ax - xMin) / (xMax - xMin) * fromIntegral (width - 1)

rowIdx = floor $ (ay - yPlotMin) / (yPlotMax - yPlotMin) * fromIntegral (height - 1) row = rowIdx -- без инверсии

in if row >= 0 && row < height && col >= 0 && col < width then set2D grid row col '+'

else grid) withOrig approx

putStrLn $ "\n" ++ replicate 80 '='

putStrLn $ printf "ГРАФИК: x=[%.3f, %.3f] y=[%.3f, %.3f]" xMin xMax yPlotMin yPlotMax putStrLn "Легенда: '*' - исходные точки, '+' - аппроксимация"

putStrLn $ " (левый нижний угол: x=0, y=0)" putStrLn $ replicate 80 '='

-- Выводим строки в обратном порядке, чтобы ось Y шла снизу вверх putStrLn " ^ Y"

mapM_ (\rowStr -> putStrLn $ " | " ++ rowStr) (reverse finalGrid)

-- Рисуем ось X

putStrLn $ " +" ++ replicate width '-' ++ "> X" putStrLn $ " 0" ++ replicate (width-2) ' ' ++ show xMax putStrLn $ replicate 80 '='

-- Текстовый вывод результатов в таблицу (без весов)

18

printResultsTable :: [PointWeight] -> Vector -> Int -> IO () printResultsTable points coefs m = do

putStrLn "\nТАБЛИЦА РЕЗУЛЬТАТОВ:" putStrLn $ replicate 60 '-'

putStrLn " x Исходный y Аппроксимация Ошибка" putStrLn $ replicate 60 '-'

mapM_ (\(x, y, _) -> do

let approx = evalHermitePoly coefs x err = y - approx

putStrLn $ printf "%8.3f %12.6f %15.6f %12.6f" x y approx err ) points

putStrLn $ replicate 60 '-'

-- Дополнительная функция: запись результатов в файл (без весов) writeResultsToFile :: FilePath -> [PointWeight] -> Vector -> Int -> IO () writeResultsToFile filename points coefs m = do

let header = "# Результаты аппроксимации полиномами Эрмита\n" ++ "# Степень полинома: " ++ show m ++ "\n" ++

"# Коэффициенты:\n" ++

concat [printf "# a_%d = %.10f\n" k (coefs !! k) | k <- [0..m]] ++ "#\n# x y_исходн y_аппрокс ошибка\n"

rows = concatMap processPoint points processPoint (x, y, _) =

let approx = evalHermitePoly coefs x err = y - approx

in printf "%.6f %.6f %.6f %.6f\n" x y approx err

footer = "\n# СКО (RMSE): " ++ show (calculateRMSE points coefs) content = header ++ rows ++ footer

writeFile filename content

putStrLn $ "Результаты сохранены в файл: " ++ filename

19

-- Функция для выполнения аппроксимации

runApproximation :: [PointWeight] -> Int -> Double -> Double -> IO () runApproximation points m minX maxX = do

putStrLn $ "\nВычисляем коэффициенты методом наименьших квадратов (m = " ++ show m ++ ")" let coefs = solveLeastSquares points m

putStrLn "\nНАЙДЕННЫЕ КОЭФФИЦИЕНТЫ:" putStrLn "k a_k"

putStrLn $ replicate 25 '-'

mapM_ (\(k, c) -> putStrLn $ printf "%-2d %15.10f" k c) (zip [0..m] coefs)

printResultsTable points coefs m

let rmse = calculateRMSE points coefs

putStrLn $ printf "\nСреднеквадратичная ошибка (RMSE): %.8f" rmse

putStrLn "\nВведите количество точек для графика n (целое, больше 2):" nStr <- getLine

let nMaybe = readMaybe nStr :: Maybe Int

let (nPoints, message) = case nMaybe of

Nothing -> (50, "Ошибка ввода. Используется n = 50")

Just n -> if n < 2 then (50, "Слишком мало точек. Используется n = 50") else (n, "")

when (not (null message)) $ putStrLn message

let xs = linspace nPoints minX maxX ys = map (evalHermitePoly coefs) xs approxPoints = zip xs ys

asciiPlot points approxPoints

20