Программа

{-# LANGUAGE ScopedTypeVariables #-}

import Data.List (nubBy, foldl', groupBy)

import Data.Function (on)

import System.IO

import Text.Printf

import Text.Read (readMaybe)

import Control.Monad (when)

import Control.Exception (catch, SomeException)

type Point = (Double, Double)

type PointWeight = (Double, Double, Double) -- (x, y, weight)

type Matrix = [[Double]]

type Vector = [Double]

-- Функция для запроса файла с обработкой ошибок

requestFilePath :: IO FilePath

requestFilePath = do

putStrLn "Введите имя файла с данными (формат: x y в каждой строке):"

getValidFilePath

getValidFilePath :: IO FilePath

getValidFilePath = do

file <- getLine

-- Пытаемся открыть файл для чтения, чтобы проверить его существование

result <- catch (do

handle <- openFile file ReadMode

hClose handle

return (Right file))

(\(e :: SomeException) -> return (Left (show e)))

case result of

Right f -> return f

Left err -> do

putStrLn $ "ОШИБКА: Файл не найден или недоступен для чтения"

putStrLn $ "Детали: " ++ takeWhile (/='\n') err -- Берем первую строку ошибки

putStrLn "Пожалуйста, введите другое имя файла:"

getValidFilePath

-- Рекуррентная формула для полиномов Эрмита

hermite :: Int -> Double -> Double

hermite 0 _ = 1.0

hermite 1 x = 2 * x

hermite n x

| n < 0 = 0.0

| otherwise = 2 * x * hermite (n-1) x - 2 * fromIntegral (n-1) * hermite (n-2) x

-- Вычисление нескольких полиномов Эрмита для одной точки

hermiteVector :: Int -> Double -> Vector

hermiteVector m x = [hermite k x | k <- [0..m]]

-- Нисходящая сортировка слиянием (merge sort)

mergeSort :: (Ord a) => [a] -> [a]

mergeSort [] = []

mergeSort [x] = [x]

mergeSort xs =

let (left, right) = splitAt (length xs `div` 2) xs

in merge (mergeSort left) (mergeSort right)

where

merge :: (Ord a) => [a] -> [a] -> [a]

merge [] ys = ys

merge xs [] = xs

merge (x:xs) (y:ys)

| x <= y = x : merge xs (y:ys)

| otherwise = y : merge (x:xs) ys

-- Сортировка точек по 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."

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

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

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 =

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

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 =

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, _) ->

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 '='

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

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

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

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

putStrLn "\nСохранить результаты в файл? (y/...)"

save <- getLine

when (save == "y" || save == "Y") $ do

putStrLn "Введите имя файла для сохранения:"

outFile <- getLine

writeResultsToFile outFile points coefs m

putStrLn "\nАппроксимация завершена успешно!"

-- Основная функция

-- Основная функция

main :: IO ()

main = do

hSetBuffering stdout NoBuffering

putStrLn $ replicate 60 '='

putStrLn "АППРОКСИМАЦИЯ МЕТОДОМ НАИМЕНЬШИХ КВАДРАТОВ"

putStrLn "в базисе полиномов Эрмита"

putStrLn $ replicate 60 '='

-- Получаем валидный путь к файлу с проверкой существования

file <- requestFilePath

-- Теперь читаем точки с обработкой возможных ошибок чтения

points <- catch (readPoints file)

(\(e :: SomeException) -> do

putStrLn $ "ОШИБКА при чтении файла: " ++ show e

putStrLn "Программа завершена."

return [])

if null points || length points < 2

then do

putStrLn "Ошибка: недостаточно точек для аппроксимации!"

putStrLn "Необходимо как минимум 2 точки."

else do

let numPoints = length points

minX = minimum [x | (x, _, _) <- points]

maxX = maximum [x | (x, _, _) <- points]

putStrLn $ printf "\nДиапазон x: [%.3f, %.3f]" minX maxX

putStrLn $ "Количество точек: " ++ show numPoints

putStrLn $ "Максимально допустимая степень полинома: 10"

putStrLn "\nВведите степень полинома Эрмита m (целое):"

mStr <- getLine

let mMaybe = readMaybe mStr :: Maybe Int

case mMaybe of

Nothing -> do

putStrLn "Ошибка ввода: введите целое число"

putStrLn "Установлена степень 0 (аппроксимация константой)"

runApproximation points 0 minX maxX

Just m -> do

-- Простая коррекция с отдельными проверками

let correctedM

| m < 0 = 0

| m > 10 = 10

| otherwise = m

-- Выводим предупреждения о коррекции

when (m < 0) $

putStrLn $ "Предупреждение: отрицательная степень " ++ show m ++ " установлена в 0"

when (m > 10) $ do

putStrLn $ "Предупреждение: степень " ++ show m ++ " превышает максимальную: 10"

putStrLn $ "Установлена максимальная степень: 10"

-- Дополнительные предупреждения

when (correctedM == 0) $

putStrLn "Аппроксимация полиномом нулевой степени (константа)"

when (correctedM > numPoints `div` 2) $

putStrLn "Предупреждение: высокая степень полинома может привести к переобучению"

runApproximation points correctedM minX maxX