esotericbot-0.0.1: hs_plugins/SK.hs

{-# OPTIONS -XScopedTypeVariables #-}

import Text.ParserCombinators.Parsec

import System.Environment

import Data.List
import Data.Maybe
import Data.Graph.Inductive
import qualified Data.Foldable as F

import Control.Monad.State
import Control.Arrow

data SK =
   App
   | S
   | K
   | I
   | PH Char
   deriving Eq

type SKM =
   StateT SKgr IO

-- for output of results
data SKstr =
   SKstr [ SKstr ]
   | ASK SK

instance Show SKstr where
   show ( SKstr sks ) =
      "(" ++ ( concat $ map show sks ) ++ ")"
   show ( ASK sk ) =
      show sk

type SKgr =
   Gr SK Int

instance Show SK where
   show App =
      "App" 
   show ( PH c ) =
      [ c ] 
   show S =
      "S"
   show K =
      "K"
   show I =
      "I"

sk_str = do
   complex_sks <- node_to_str 0
   let skstr = simplify complex_sks
   return $ 
      case skstr of
         SKstr sks ->
            sks
         _ ->
            [ skstr ]

simplify ( SKstr sks ) =
   if length sks == 1
      then
         simplify $ head sks
      else
         SKstr $ map simplify sks
simplify x =
   x 

eval first red n can_fail = do
   msk <- find_term n
   maybe next
         ( \ ( sk , p ) -> do
            input <- suck_input sk p [ ]
            if length input >= suck_level sk
               then do
                  sub first red ( snd $ head p , snd $ head $ tail p ) sk input
                  eval False red n False
               else
                  next
         )
         msk
   where
   next =
      if can_fail
         then 
            sk_str
         else
            eval False red ( n + 1 ) True

sub first red ( n , parent ) sk input = do
   oldgr <- getGr
   if ( red && not first ) then sk_str >>= liftIO . output_sk_strs else return ( )
   let writeNode a g = do
          ( x , _ ) <- valueOf a
          case x of
             App ->
                putGr $ insEdges ( inn oldgr n ++ ( mkEdgesFrom n $ out oldgr a ) ) $ insNode ( n , x ) $ delNode n g
             _ ->
                putGr $ insEdges ( inn oldgr n ) $ insNode ( n , x ) $ delNode n g
   case sk of
      K ->
         case input of
            [ a , b ] -> do
               writeNode a $ delNode a $ cleanupNode b oldgr
            _ ->
               return ( )
      S -> do
         case input of
            [ a , b , c ] -> do
               ( aVal , _ ) <- valueOf a
               ( bVal , _ ) <- valueOf b
               ( cVal , _ ) <- valueOf c
               cloneNode c a
               gr <- getGr
               let bc = [ ( b , newb , 0 ) , ( b , newc , 1 ) ]
                   [ newb , newc ] = newNodes 2 gr
                   newbEdges = mkEdgesFrom newb $ out gr b
                   newcEdges = mkEdgesFrom newc $ out gr c
                   nEdges = mkEdgesFrom n $ out oldgr a
                   parentEdges = [ ( parent , n , 0 ) , ( parent , a , 1 ) , ( parent , b , 2 ) ]
                   without_old_nodes = delNode n $ delNode c $ delNode b $ gr
                   new_node_gr = insNode ( b , App ) 
                                 $ insNode ( newc , cVal )
                                 $ insNode ( newb , bVal )
                                 $ insNode ( n , aVal ) 
                                 $ without_old_nodes
                   new_gr = insEdges parentEdges 
                            $ insEdges newbEdges 
                            $ insEdges newcEdges
                            $ insEdges nEdges 
                            $ insEdges bc 
                            $ new_node_gr 
               putGr new_gr
                   
            _ ->
               return ( )
      I ->
         case input of
            [ a ] -> do
               writeNode a $ delNode a oldgr
            _ ->
               return ( )
   where
   mkEdgesFrom n es = map ( \ ( _ , to , v ) -> ( n , to , v ) ) es 

cloneNode from to = do
   gr <- getGr
   str <- node_to_str from
   putGr $ delNode to gr
   add_node_str to str

add_node_str n skstr = do
   gr <- getGr
   case skstr of
      SKstr sks -> do
         putGr $ insNode ( n , App ) gr 
         mapM_ ( joinToNode n ) sks 
      ASK x ->
         putGr $ insNode ( n , x ) gr
   where
   joinToNode n sk = do
      gr <- getGr
      ( _ , seq ) <- valueOf n
      let newEdge = if null seq
                       then 0 
                       else fst ( maximum seq ) + 1
          newNode = head $ newNodes 1 gr
      case sk of
         SKstr sks -> do
            putGr $ insEdge ( n , newNode , newEdge ) $ insNode ( newNode , App ) gr
            mapM_ ( joinToNode newNode ) sks
         ASK x -> do
            putGr $ insEdge ( n , newNode , newEdge ) $ insNode ( newNode , x ) gr

node_to_str n = do
   ( sk , seq ) <- valueOf n
   case sk of
      App -> do
         linkedVals <- mapM node_to_str $ map snd seq
         return $ SKstr linkedVals
      _ ->
         return $ ASK sk
    
 
cleanupNode n gr =
   let ( Just ( _ , _ , sk , seq ) , withoutn ) = match n gr
   in
   case sk of
      App ->
         foldr cleanupNode withoutn $ map snd seq
      _ ->
         withoutn
         
               
sk_panic msg =
   error $ unlines [ "SK panic!  The possible happened!!!1"
                   , msg
                   ]

valueOf a = do
   gr <- getGr
   maybe ( sk_panic $ "Lookup for node " ++ show a ++ " failed!" )
         ( \ ( _ , _ , sk , sks ) -> return ( sk , sort sks ) )
         ( fst $ match a gr )
   
   
suck_input sk p sucked = do
   if could_suck_more sk sucked
      then do
         ms <- suck_one p
         maybe ( return sucked ) 
               ( \ ( newp , s ) -> suck_input sk newp $ sucked ++ [ s ] )
               ms
      else
         return sucked

suck_one ( ( Just edge_to_parent , _ ) : next@( ( _ , parent_address ) : rest ) ) = do
    ( _ , sequence ) <- valueOf parent_address
    let mnext_edge_and_term = find ((<) edge_to_parent . fst ) sequence
    maybe ( suck_one next )
          ( \ ( next_edge , next_term ) -> do
               return $ Just ( ( Just next_edge , next_term ) : next , next_term )
          )
          ( mnext_edge_and_term)

suck_one _ =
   return Nothing

getGr :: SKM SKgr
getGr =
   get

putGr :: SKgr -> SKM ( )
putGr graph = do
   put graph 

find_term n = do
   terms <- first_terms ( Nothing , 0 ) [ ]
   if length terms > n
      then
         return $ Just $ terms !! n
      else
         return Nothing

first_terms :: ( Maybe Int , Int ) -> [ ( Maybe Int , Int ) ] -> SKM [ ( SK , [ ( Maybe Int , Int ) ] ) ]
first_terms addr@( maybe_edge , n ) path = do
   ( sk , sequence ) <- valueOf n    
   skterm ( if null sequence
               then
                  return [ ] 
               else do
                  ( nVal , _ ) <- valueOf $ snd $ head sequence
                  skterm ( do
                            let tovisit = map ( first Just ) sequence
                            ts <- mapM ( flip first_terms ( addr : path ) ) tovisit
                            let just_ts = concat ts
                            if null just_ts
                               then
                                  return [ ]
                               else
                                  return just_ts
                         )
                         ( const $ do 
                            return [ ( nVal , ( first Just $ head sequence ) : addr : path ) ] 
                         )
                         nVal
          )
          ( const $
             return [ ]
          )
          sk

skterm f g t =
   case t of
      App ->
         f
      PH c ->
         f
      x ->
         g x

suck_level K = 2
suck_level I = 1
suck_level S = 3
 
sk_strP = do
   sk <- noneOf ")"
   case sk of
      'k' -> isK
      's' -> isS
      'i' -> isI
      'K' -> isK
      'S' -> isS
      'I' -> isI
      '(' -> do
         sks <- many sk_strP
         char ')'
         return $ SKstr sks
      pl ->
         return $ ASK $ PH pl
   where
   isK = return $ ASK K
   isS = return $ ASK S
   isI = return $ ASK I


could_suck_more sk sucked =
   if length sucked >= suck_level sk
      then
         False             
      else
         True
main = do
   prog <- getContents
   args <- getArgs
   exec_sk ( not $ null args ) prog

exec_sk red skprog = do
   ( _ , skgr ) <- parse_sk skprog
   ss <- evalStateT ( eval True red 0 False ) skgr
   output_sk_strs ss
 
output_sk_strs :: [ SKstr] -> IO ( )
output_sk_strs sk_strs = do
   putStrLn $ concat $ map show sk_strs
 
parse_sk sk = do
   name <- getProgName
   case parse ( many $ sk_strP ) name sk of
      Left err ->
         error $ show err
      Right skstr ->
         build_initial $ SKstr skstr

build_initial skstr =
   flip runStateT empty $ add_node_str 0 skstr