descent.hs

{-# LANGUAGE BangPatterns #-}

import System.Environment
import qualified Data.Vector.Unboxed as V
import Debug.Trace (traceShowId)

trace x = traceShowId x

data Matrix a = Mat !Int !Int (V.Vector a)

instance (V.Unbox a, Show a) => Show (Matrix a) where
  show mat@(Mat m _ _) = unlines $ map showRow $ map (flip matRow mat) [0..m-1]
    where
      showRow = unwords . map show . V.toList

matMake xss = Mat m n $ V.fromList $ concat xss
  where
    m = length xss
    n = length $ head xss

matBuild m n f = matMake [[f i j | j <- [0..n-1]] | i <- [0..m-1]]

matElem i j (Mat m n v) = V.unsafeIndex v (i*n+j)
matRow i (Mat m n v) = V.unsafeSlice (i*n) n v
matNrows (Mat m _ _) = m
matNcols (Mat _ n _) = n

matTranspose mat@(Mat m n _) = matBuild n m (\i j -> matElem j i mat)

data Features = Features { featM :: Matrix Double, featMT :: Matrix Double }

features xss = Features m mt
  where
    m = matMake xss
    mt = matTranspose m

featNrows = matNrows . featM
featNcols = matNcols . featM

type Vector = V.Vector Double

vecMake = V.fromList
vecElem v i = V.unsafeIndex v i

type Theta = Vector

type Outputs = Vector

type LearnRate = Double

dot :: Vector -> Vector -> Double
dot va vb = V.foldl' k 0.0 $ V.generate n id
  where
    n = V.length va
    k s i = s + (vecElem va i) * (vecElem vb i)

model :: Vector -> Theta -> Double
model xs th = dot xs th

err :: Features -> Outputs -> Theta -> Int -> Double
err fs ys th i = model (matRow i $ featM fs) th - vecElem ys i

descent :: LearnRate -> Features -> Outputs -> Theta -> Theta
descent r fs ys th =
  V.zipWith (-) th $ V.generate n move
  where
    m = featNrows fs
    n = featNcols fs
    rr = r / (fromIntegral m)
    errs = V.generate m (err fs ys th)
    move j = rr * dot (errs) (matRow j $ featMT fs)

nDescent 0 _ _  _  !th = th
nDescent n r xm ys !th = nDescent (n-1) r xm ys (descent r xm ys th)

readInput path = return . map read . lines =<< readFile path

main = do
  [n] <- map read `fmap` getArgs
  x <- readInput "ex2x.txt"
  y <- readInput "ex2y.txt"
  let xm = features $ map ((1:) . (:[])) x 
  let ys = vecMake y
  let th = vecMake [0, 0]
  let r = 0.07
  let d1500 = nDescent n r xm ys th
  print d1500