Hello everyone,

I just implemented an Artificial Neural Network but I'm having a serious memory leak. I was very careful of using tail recursion all over my code, but for some reason (a.k.a lazyness) my program is misusing incredible ammounts of RAM. I read the whole chapter 25 of Real World Haskell trying to find a solution with no luck. Maybe somebody can take a look at the code to help me out with this problem, I would really appreciate it.

Thanks A LOT in advance,

Hector Guilarte

Ps: The file is also attached

Ps2: The code is written in Spanglish, sorry for that, I'm working on that bad habbit...

module Main where

import Control.Monad
import System.IO
import qualified Random
import System.IO.Unsafe
import System.Environment
import Data.List

data ANN = ANN Layer Layer Layer -- ^ Red Neuronal de 3 capas
    deriving (Eq, Show)

type Layer = [Neuron] -- ^ Lista de Neuronas que conforman la capa

data Neuron = Neuron [(Float,Float)] Float -- ^ Lista de (pesos,xs) y umbral asociado
    deriving (Eq, Show)

neurona:: Neuron -> -- ^ [(Pesos,Xs)] y Umbral
                Float
neurona (Neuron entrada umbral) =
    let entradaTupla = unzip entrada
        pesos = fst entradaTupla
        xs = snd entradaTupla
        suma = foldl' (+) (-umbral) (zipWith (*) xs pesos)
    in sigmoidal suma

neurona2:: [(Float,Float)] -> -- ^ [(Pesos,Xs)]
                    Float -> -- ^ Umbral
                    Float
neurona2 valores umbral =
    let entradaTupla = unzip valores
        pesos = fst entradaTupla
        xs = snd entradaTupla
        suma = foldl' (+) umbral (zipWith (*) xs pesos)
    in sigmoidal suma

-- ANN [] [Neuron [(4.7621,0.9993291),(4.7618,0.94501287)] 7.3061,Neuron [(6.3917,0.9993291),(6.3917,0.94501287)] 2.8441] [Neuron [(-10.3788,0.9993291),(9.7691,0.94501287)] 4.5589]

sigmoidal:: Float -> Float
sigmoidal x = 1 / (1 + (exp (-x)))

main:: IO()
main = do
--        nombreArchivo <- getArgs
--        archivo <- readFile (head nombreArchivo)
        pesos <- pesosIniciales 10000
        randomXs <- generarRandomXs 5000
        randomYs <- generarRandomYs 5000
        let conjunto = generar 200 0 0 randomXs randomYs []
        --print conjunto
--        let lista = parsearString archivo [[]]
--        let splitted = split lista []
        let (a,b,c) = (unzip3 (take 200 conjunto))
        --let (a,b,c) = ([0,1,0,1],[0,0,1,1],[0,1,1,0])
        let ejemplos = zipWith (ajustarEjemplos) a b
--        print ejemplos
        let nuevaRed = armarRed 2 8 1 pesos
        let entrenada = train nuevaRed ejemplos c
        let redInicializada = map (iniciarXsRed entrenada) ejemplos
        let resultados = map resultadoRed1Output (map evaluarRed redInicializada)
        print nuevaRed
        print entrenada
        print resultados
        return ()

ajustarEjemplos:: Float -> Float -> [Float]
ajustarEjemplos a b = [a,b]

train:: ANN -> [[Float]] -> [Float] -> ANN
train red ejemplosTodos esperadosTodos =
    let entrenado = entrenamiento red ejemplosTodos esperadosTodos [] 200
        squaredErrors = snd entrenado
    in if squaredErrors < 3 then fst entrenado
        else train (fst entrenado) ejemplosTodos esperadosTodos

-- ENTRENAMIENTO

entrenamiento:: ANN -> [[Float]] -> [Float] -> [Float] -> Int -> (ANN,Float)
entrenamiento red _ _ accum 0 =
    let squaredErrors = foldl' (+) 0 (map (**2) accum)
    in (red,squaredErrors)
entrenamiento red ejemplos esperados accum epoch =
    let redInicializada = iniciarXsRed red (head ejemplos)
        redEvaluada = evaluarRed redInicializada
        redAjustada = ajustarPesos redEvaluada (head esperados)
        error = (head esperados) - (resultadoRed1Output redAjustada)
    in entrenamiento redAjustada (tail ejemplos) (tail esperados) (accum ++ [error]) (epoch-1)

resultadoRed1Output:: ANN -> Float
resultadoRed1Output (ANN _ _ [(Neuron ((_,xs):_) _)]) = xs

iniciarXsRed:: ANN -> [Float] -> ANN
iniciarXsRed (ANN inputLayer hiddenLayer outputLayer) valores =
    let inputNueva = zipWith ajustarXsInput inputLayer valores
    in (ANN inputNueva hiddenLayer outputLayer)

ajustarXsInput:: Neuron -> Float -> Neuron
ajustarXsInput (Neuron listaNeurona threshold) xsInput =
    let listaNueva = map (ajustarXs xsInput) listaNeurona
    in (Neuron listaNueva threshold)
-- FIN ENTRENAMIENTO

pesosIniciales :: Int -> IO [Float]
pesosIniciales n = do
    (replicateM n (Random.getStdRandom intervalo))
        where
            intervalo = Random.randomR (-0.5,0.5)

parsearString:: String -> [String] -> [String]
parsearString [] lista = (tail lista)
parsearString (x:xs) lista = if x == '\n' then parsearString xs ([]:lista)
                                else parsearString xs (((head lista) ++ [x]):(tail lista))

split:: [String] -> [(Float,Float,Float)] -> [(Float,Float,Float)]
split [] accum = accum
split (x:xs) accum =
    let first = readNum x ""
        fstNum = read $ fst first
        second = readNum (snd first) ""
        sndNum = read $ fst second
        third = readNum (snd second) ""
        thrdNum = if (head $ fst third) == 'A' then 0
                    else 1
    in split xs ([(fstNum,sndNum,thrdNum)]++accum)

readNum:: String -> String -> (String,String)
readNum [] num = ([(head num)],num)
readNum (x:xs) num = if x == ' ' then (num,xs)
                        else (if x == '\n' then (num,xs)
                                else readNum xs (num ++ [x])
                             )

generar:: Int -> Int -> Int -> [Float] -> [Float] -> [(Float,Float,Float)] -> [(Float,Float,Float)]
generar total dentro fuera randomXs randomYs accum
    | total == dentro + fuera = accum
    | dentro == total `div` 2 =
        let x = head randomXs
            y = head randomYs
            isDentro = ((x-15)**2) + ((y-6)**2) <= 9
        in if isDentro then generar total dentro fuera (tail randomXs) (tail randomYs) accum
            else generar total dentro (fuera+1) (tail randomXs) (tail randomYs) (accum ++ [(x,y,0)])
    | fuera == total `div` 2 =
        let x = head randomXs
            y = head randomYs
            isDentro = ((x-15)**2) + ((y-6)**2) <= 9
        in if isDentro then generar total (dentro+1) fuera (tail randomXs) (tail randomYs) (accum ++ [(x,y,1)])
            else generar total dentro fuera (tail randomXs) (tail randomYs) accum
    | otherwise =
        let x = head randomXs
            y = head randomYs
            isDentro = ((x-15)**2) + ((y-6)**2) <= 9
        in if isDentro then generar total (dentro+1) fuera (tail randomXs) (tail randomYs) (accum ++ [(x,y,1)])
            else generar total dentro (fuera+1) (tail randomXs) (tail randomYs) (accum ++ [(x,y,0)])

generarRandomXs :: Int -> IO [Float]
generarRandomXs n = do
    (replicateM n (Random.getStdRandom intervalo))
        where
            intervalo = Random.randomR (0.0,20.0)

generarRandomYs :: Int -> IO [Float]
generarRandomYs n = do
    (replicateM n (Random.getStdRandom intervalo))
        where
            intervalo = Random.randomR (0.0,12.0)

-- ARMAR RED
armarRed:: Int -> Int -> Int -> [Float] -> ANN
armarRed numNeuronasInput numNeuronasHidden numNeuronasOutput randoms =
    let layerInput = armarLayerInput numNeuronasInput numNeuronasHidden randoms []
        layerHidden = armarLayerHidden numNeuronasHidden numNeuronasOutput (snd layerInput) []
        layerOutput = armarLayerOutput numNeuronasOutput (snd layerHidden) []
    in (ANN (fst layerInput) (fst layerHidden) layerOutput)

armarLayerInput:: Int -> Int -> [Float] -> Layer -> (Layer,[Float])
armarLayerInput 0 _ randoms accum = (accum,randoms)
armarLayerInput numNeuronasInput numNeuronasHidden randoms accum =
    let listaNeurona = armarListaNeuronasInput numNeuronasHidden randoms []
        newRandoms = snd listaNeurona
        neurona = [(Neuron (fst listaNeurona) 0)]
    in armarLayerInput (numNeuronasInput-1) numNeuronasHidden newRandoms (accum ++ neurona)

armarLayerHidden:: Int-> Int -> [Float] -> Layer -> (Layer,[Float])
armarLayerHidden 0 _ randoms accum = (accum,randoms)
armarLayerHidden numNeuronasHidden numNeuronasOutput randoms accum =
    let listaNeurona = armarListaNeuronasHidden numNeuronasOutput randoms []
        neurona = [(Neuron (fst listaNeurona) (head $ snd listaNeurona))]
    in armarLayerHidden (numNeuronasHidden-1) numNeuronasOutput (tail $ snd listaNeurona) (accum ++ neurona)

armarListaNeuronasHidden:: Int -> [Float] -> [(Float,Float)] -> ([(Float,Float)],[Float])
armarListaNeuronasHidden 0 randoms accum = (accum,randoms)
armarListaNeuronasHidden numElems randoms accum =
    let pesosYxs = [((head randoms),(head $ tail randoms))]
    in armarListaNeuronasHidden (numElems-1) (tail $ tail randoms) (accum ++ pesosYxs)

armarListaNeuronasInput:: Int -> [Float] -> [(Float,Float)] -> ([(Float,Float)],[Float])
armarListaNeuronasInput 0 randoms accum = (accum,randoms)
armarListaNeuronasInput numElems randoms accum =
    let pesosYxs = [((head randoms),0)]
    in armarListaNeuronasInput (numElems-1) (tail randoms) (accum ++ pesosYxs)

armarLayerOutput:: Int -> [Float] -> Layer -> Layer
armarLayerOutput 0 _ accum = accum
armarLayerOutput numNeuronasHidden randoms accum =
    let neurona = [(Neuron [(0,(head randoms))] (head $ tail randoms))]
    in armarLayerOutput (numNeuronasHidden-1) (tail $ tail randoms) (accum ++ neurona)

-- FIN ARMAR RED

-- EVALUAR RED

evaluarRed:: ANN -> ANN
evaluarRed (ANN inputLayer hiddenLayer outputLayer) =
    let newHidden = ajustarLayer inputLayer hiddenLayer [] 0
        newOutput = ajustarLayer newHidden outputLayer [] 0
    in (ANN inputLayer newHidden newOutput)

ajustarLayer:: Layer -> Layer -> Layer -> Int -> Layer
ajustarLayer _ [] accum numNeurona = accum
ajustarLayer leftLayer ((Neuron listaNeurona threshold):rightLayer) accum numNeurona =
    let valorLayer = evaluarLayer leftLayer threshold numNeurona
        listaNeuronaNew = map (ajustarXs valorLayer) listaNeurona
    in ajustarLayer leftLayer rightLayer (accum ++ [(Neuron listaNeuronaNew threshold)]) (numNeurona+1)

ajustarXs:: Float -> (Float,Float) -> (Float,Float)
ajustarXs xs (peso,_) = (peso,xs)

evaluarLayer:: Layer -> Float -> Int -> Float
evaluarLayer layer threshold numNeurona =
    let listaTuplas = extraerTuplaLayer layer numNeurona []
        valor = neurona2 listaTuplas threshold
    in valor

extraerTuplaLayer:: Layer -> Int -> [(Float,Float)] -> [(Float,Float)]
extraerTuplaLayer [] _ accum = accum
extraerTuplaLayer ((Neuron tupla _):resto) numNeurona accum = extraerTuplaLayer resto numNeurona (accum ++ [(tupla !! numNeurona)])

-- FIN EVALUAR RED

-- AJUSTAR RED

ajustarPesos:: ANN -> Float -> ANN
ajustarPesos salida@(ANN inputLayer hiddenLayer outputLayer) esperado =
    let outputNuevo = map (ajustarPesoOutput esperado) outputLayer
        gradientes = snd $ unzip outputNuevo
        hiddenNuevo = map (ajustarPesoHidden gradientes) hiddenLayer
        gradientes2 = snd $ unzip hiddenNuevo
        inputNuevo = map (ajustarPesoInput gradientes2) inputLayer
    in (ANN inputNuevo (fst $ unzip hiddenNuevo) (fst $ unzip outputNuevo))

ajustarPesoOutput:: Float -> Neuron -> (Neuron,Float)
ajustarPesoOutput esperado (Neuron [(peso,obtenido)] threshold) =
    let error = esperado-obtenido
        gradiente = obtenido*(1-obtenido)*error
        deltaTheta = tasaAprendizaje*(-1)*gradiente
        thresholdNuevo = threshold + deltaTheta
    in ((Neuron [(peso,obtenido)] thresholdNuevo),gradiente)

ajustarPesoHidden:: [Float] -> Neuron -> (Neuron,Float)
ajustarPesoHidden gradientes (Neuron listaNeurona threshold) =
    let (pesosViejos,xsViejos) = unzip listaNeurona
        pesosAjustados = zipWith ajustarPesosHidden listaNeurona gradientes
        sumatoriaGradientes = foldl' (+) 0 (zipWith (*) gradientes pesosViejos)
        gradiente = (head xsViejos)*(1-(head xsViejos))*sumatoriaGradientes
        thresholdNuevo = tasaAprendizaje*(-1)*gradiente
    in ((Neuron pesosAjustados thresholdNuevo),gradiente)

ajustarPesoInput:: [Float] -> Neuron -> Neuron
ajustarPesoInput gradientes (Neuron listaNeurona threshold) =
    let (pesosViejos,xsViejos) = unzip listaNeurona
        pesosAjustados = zipWith (+) pesosViejos (map (*tasaAprendizaje) (zipWith (*) gradientes xsViejos))
        listaNeuronaNueva = zip pesosAjustados xsViejos
    in (Neuron listaNeuronaNueva threshold)


ajustarPesosHidden:: (Float,Float) -> Float -> (Float,Float)
ajustarPesosHidden (pesoViejo,xs) gradiente =
    let deltaW = tasaAprendizaje*xs*gradiente
        pesoNuevo = pesoViejo + deltaW
    in (pesoNuevo,xs)

-- FIN AJUSTAR RED

tasaAprendizaje = 0.1