{- Copyright 2007 Kari Pahula 
 - Licensed under GNU GPL version 2 or later, as published by Free
 - Software Foundation.
 - See http://www.gnu.org/licenses/old-licenses/gpl-2.0.html -}

import Database.HDBC
import Database.HDBC.PostgreSQL
import Data.Array.IArray
import qualified Data.Map as M
import Data.Array.IO
import Data.Array.Unboxed
import Control.Monad
import Data.List
import System.IO
import Numeric(showFFloat)

getWithReaders ::  Connection -> IO ((Array Int Int), (M.Map Int (Int,String)))
getWithReaders dbh = do
  vals <- quickQuery dbh "SELECT cid, title \
                         \FROM subscriptions JOIN comics USING (cid) \
                         \GROUP BY cid, title ORDER BY cid" []
  let arr = listArray (1,(length vals)) $
            map (\[cid,_] -> (fromSql cid)::Int) vals
      assoc = M.fromDistinctAscList $
              map (\((idx,cid),title) -> (cid,(idx,title))) $
              zip (assocs arr) (map (\ [_,t] -> (fromSql t)::String) vals)
  return (arr, assoc)

userSubscr subscr idxs =
    forM_ [(x,y) | x <- idxs, y <- idxs, x /= y]
              (\i -> do
                 a <- readArray subscr i ; writeArray subscr i (a+1))

getSubscr dbh arr assoc = do
  let comics = snd $ bounds arr
  subscr::(IOUArray (Int,Int) Int) <- newArray ((1,1),(comics,comics)) 0
  uids' <- quickQuery dbh "SELECT uid FROM subscriptions GROUP BY uid" []
  let uids = map (\[x] -> (fromSql x)::Int) uids'
  sth <- prepare dbh "SELECT cid FROM subscriptions WHERE uid=?"
  let userSubscr' = userSubscr subscr
  forM_ uids
        (\x -> do execute sth [toSql x]
                  cids <- fetchAllRows sth
                  userSubscr' $ map (\ [x] -> fst (assoc M.! (fromSql x))) cids)
  subscr'::(UArray (Int,Int) Int) <- unsafeFreeze subscr
  return subscr'

getRelated :: (UArray (Int,Int) Int) -> IO (UArray (Int,Int) Int)
getRelated subscr = do
  let comics = snd $ snd $ bounds subscr
  related::(IOUArray (Int,Int) Int) <- newArray ((1,1),(comics,comics)) 0
  forM_ [(i,j) | i <- [1..comics], j <- [1..comics], i /= j]
            (\(i,j) -> do
               let scale = subscr ! (i,j)
               if scale /= 0 then
                   do forM_ [k | k <- [1..comics], k /= i]
                                (\k -> do let i' = (i,k)
                                          x <- readArray related i'
                                          let s = subscr ! (j,k)
                                          writeArray related i' (x+scale*s*s))
                  else return ())
  related'::(UArray (Int,Int) Int) <- unsafeFreeze related
  return related'

oneRec :: Int -> (UArray (Int,Int) Int) -> (UArray (Int,Int) Int)
       -> Int -> [(Int,Float)]
oneRec comics subscr related i =
 let
     maxSub = fromIntegral $ (foldr max 0) $
              map (\j -> subscr ! (i,j)) [1..comics]
     maxRel = log (1+fromIntegral ((foldr max 0) $
                                   map (\j -> related ! (i,j)) [1..comics]))
     fudge = log (1+maxSub)
     rel = take 10 $ sortBy (\x y -> (snd y) `compare` (snd x))
           (map (\j -> (j,(fromIntegral $ subscr ! (i,j)) -
                        (log(1 + (fromIntegral $ related ! (i,j))) /
                         maxRel * fudge *
                         sqrt maxSub)))
            [1..comics])
 in
   if maxRel <= 0 || (((snd $ rel !! 0) - (snd $ rel !! 9) < 0.05)
                      && (snd $ rel !! 0) < 1) then []
   else rel

getRecommend :: (UArray (Int,Int) Int) -> (UArray (Int,Int) Int)
             -> (Array Int [(Int,Float)])
getRecommend subscr related =
  let comics = snd $ snd $ bounds subscr
      oneRec' = oneRec comics subscr related
  in listArray (1, comics) $ map (\i -> oneRec' i) [1..comics]

outputRel arr assoc recommend i = do
  if recommend ! i == [] then return () else
      do
        out <- openFile ("/home/kaol/related_work/"
                         ++ show (arr ! i)) WriteMode
        hPutStr out "<div class=\"related\">\n<h4>Related</h4>\n<table>\n"
        forM_ (take 10 $ takeWhile ((>0) . snd) (recommend ! i))
         (\x -> do let score = snd x
                   let idx = fst x
                   let cid = arr ! idx
                   let title = snd (assoc M.! cid)
                   hPutStr out ("<tr><td>" ++ (showFFloat (Just 2) score "") ++
                                "<td><a href=\"info.html?cid=" ++
                                (show cid) ++
                                "\">" ++ title ++ "</a>\n"))
        hPutStr out "</table>\n<i>(experimental)</i></div>\n"
        hClose out

main = do
  dbh <- connectPostgreSQL "dbname=piperka"
  (arr, assoc) <- getWithReaders dbh
  subscr <- getSubscr dbh arr assoc
  disconnect dbh
--  related <- readRelated $ snd $ bounds arr
  related <- getRelated subscr
--  writeRelated related
  let recommend = getRecommend subscr related
  forM_ [1..(snd $ snd $ bounds subscr)]
       (outputRel arr assoc recommend)

writeRelated related = do
  let comics = snd $ snd $ bounds related
  out <- openFile "/home/kaol/h_related" WriteMode
  forM_ [1..comics]
            (\i -> do
               forM_ [1..comics]
                         (\j -> do hPutStr out
                                               ((show $ related ! (i,j))
                                                ++ " "))
               hPutStr out "\n")
  hClose out

readRelated comics = do
  related::(IOUArray (Int,Int) Int) <- newArray ((1,1),(comics,comics)) 0
  inF <- openFile "/home/kaol/h_related" ReadMode
  forM_ [1..comics]
            (\i -> do
               line <- hGetLine inF
               forM_ (zip [1..comics] (map read $ words line))
                     (\(j,val) -> do writeArray related (i,j) val))
  related'::(UArray (Int,Int) Int) <- unsafeFreeze related
  return related'