esotericbot-0.0.5: hs_plugins/SK.hs

import Text.ParserCombinators.Parsec

import System.Environment

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

import Control.Monad.Stream as C
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 ) =
      "(" L.++ ( L.concat $ L.map show sks ) L.++ ")"
   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 L.length sks == 1
      then
         simplify $ L.head sks
      else
         SKstr $ L.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 L.length input >= suck_level sk
               then do
                  sub first red ( snd $ L.head p , snd $ L.head $ L.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 L.++ ( 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 = L.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 
         C.mapM_ ( joinToNode n ) sks 
      ASK x ->
         putGr $ insNode ( n , x ) gr
   where
   joinToNode n sk = do
      gr <- getGr
      ( _ , seq ) <- valueOf n
      let newEdge = if L.null seq
                       then 0 
                       else fst ( L.maximum seq ) + 1
          newNode = L.head $ newNodes 1 gr
      case sk of
         SKstr sks -> do
            putGr $ insEdge ( n , newNode , newEdge ) $ insNode ( newNode , App ) gr
            C.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 <- C.mapM node_to_str $ L.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 ->
         L.foldr cleanupNode withoutn $ L.map snd seq
      _ ->
         withoutn
         
               
sk_panic msg =
   error $ L.unlines [ "SK panic!  The possible happened!!!1"
                   , msg
                   ]

valueOf a = do
   gr <- getGr
   maybe ( sk_panic $ "Lookup for node " L.++ show a L.++ " 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 L.++ [ 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 L.length terms > n
      then
         return $ Just $ terms L.!! 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 L.null sequence
               then
                  return [ ] 
               else do
                  ( nVal , _ ) <- valueOf $ snd $ L.head sequence
                  skterm ( do
                            let tovisit = L.map ( first Just ) sequence
                            ts <- C.mapM ( flip first_terms ( addr : path ) ) tovisit
                            let just_ts = L.concat ts
                            if L.null just_ts
                               then
                                  return [ ]
                               else
                                  return just_ts
                         )
                         ( const $ do 
                            return [ ( nVal , ( first Just $ L.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 L.length sucked >= suck_level sk
      then
         False             
      else
         True
main = do
   prog <- getContents
   args <- getArgs
   exec_sk ( not $ L.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 $ L.concat $ L.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