fork download
copy 
  1. {-# LANGUAGE GADTs, RecordWildCards, FlexibleInstances
  2.   #-}
  3. import Control.Applicative
  4. import Data.Function
  5. import Data.List
  6.  
  7. goatse = do
  8.   g <- choice' ["g", "9", "6", "Г", "Γ", "r"]
  9.   o <- choice' ["0", "о", "ο", "()"]
  10.   a <- choice' ["a", "4", "α", "@"]
  11.   t <- choice' ["t", "7", "+", "т", "m", "τ"]
  12.   s <- choice' ["s", "5", "с", "σ", "c", "$"]
  13.   e <- choice' ["e", "3", "е", "ε"]
  14.   let str = concat [g, o, a, t, s, e]
  15.   {- ideone не ест юникодики, не беда -- введём костыль (ниже) -}
  16.   guard $ all ((<255).fromEnum) str
  17.   return str
  18.  
  19. choice' = choice . (zip [1..]) 
  20.  
  21. class Monad m => MonadVoretion m where
  22.   -- | Bernoulli distribution. Returns either of the arguments with
  23.   -- certain probability
  24.   fork :: Float  -- ^ Probability of the first value
  25.        -> a      -- ^ First value
  26.        -> a      -- ^ Second value
  27.        -> m a
  28.  
  29.   -- | Aborts execution if some condition isn't met
  30.   guard :: Bool  -- ^ Condition
  31.         -> m ()
  32.  
  33. data Sample m a where
  34.   Fork :: {
  35.     _metaInfo :: !m
  36.   , _left
  37.   , _right :: r
  38.   , _bias :: !Float
  39.   , _next :: r -> Sample m a
  40.   } -> Sample m a
  41.   -- | Val is just a pure value
  42.   Val :: {
  43.     _unVal :: a
  44.   } -> Sample m a
  45.   -- | Guard checks some expression and backtracks if it isn't true
  46.   Guard :: {
  47.     _metaInfo :: !m
  48.   , _guarded :: Sample m a
  49.   } -> Sample m a
  50.   Zero :: Sample m a
  51.  
  52. instance Functor (Sample m) where
  53.   fmap f a@Val{_unVal=v} = a{_unVal=f v}
  54.   fmap f a@Fork{..} = Fork {
  55.       _next = \a -> fmap f $ _next a
  56.     , ..
  57.     }
  58.   fmap _ Zero = Zero
  59.   fmap f a@Guard{..} = Guard {
  60.       _guarded = fmap f _guarded
  61.     , ..
  62.     }
  63.  
  64. instance Applicative (Sample m) where
  65.   pure a = Val a
  66.  
  67.   Val{_unVal=f} <*> a = fmap f a
  68.   Fork{..} <*> a = Fork {
  69.       _next = \x -> (_next x) <*> a
  70.     , ..
  71.     }
  72.   Zero <*> _ = Zero
  73.   Guard{..} <*> a = Guard {
  74.       _guarded = _guarded <*> a
  75.     , ..
  76.     }
  77.  
  78. instance Monad (Sample m) where
  79.   Val{_unVal=v} >>= f = f v
  80.   Fork{..}      >>= f = Fork {
  81.        _next = \a -> _next a >>= f
  82.      , ..
  83.      }
  84.   Zero          >>= _ = Zero
  85.   Guard{..}     >>= f = Guard {
  86.       _guarded = _guarded >>= f
  87.     , ..
  88.     }
  89.  
  90.   return = pure
  91.  
  92. class Default a where
  93.   deFault :: a
  94.  
  95. instance Default () where
  96.   deFault = ()
  97.  
  98. instance (Default m) => MonadVoretion (Sample m) where
  99.   fork b x y = Fork {
  100.       _metaInfo = deFault
  101.     , _left = x
  102.     , _right = y
  103.     , _bias = b
  104.     , _next = \a -> Val{_unVal=a}
  105.     }
  106.  
  107.   guard False = Zero
  108.   guard True = Guard {
  109.       _guarded = Val ()
  110.     , _metaInfo = deFault
  111.     }
  112.  
  113. choice :: MonadVoretion m => [(Float, a)] -> m a
  114. choice l = go (reverse $ scanl (\a b -> fst b + a) 0 l) $ reverse l 
  115.   where
  116.     go _ [(_,x)] = return x
  117.     go (pc:tp) ((p,x):t) = do
  118.       c <- fork (p/pc) True False
  119.       if c then
  120.         return x
  121.       else
  122.         go tp t
  123.  
  124. cobenation :: Float -> Sample () b -> [(Float, b)]
  125. cobenation ε = go 1
  126.   where
  127.     go _ Zero = []
  128.     go n _ | n<ε = []
  129.     go n Val{_unVal=v} = [(n, v)]
  130.     go n Guard{_guarded=g} = go n g
  131.     go n Fork{_bias=b, _next=f, _left=l, _right=r} = go (n*b) (f l) ++ go (n*(1-b)) (f r)
  132.  
  133. main = mapM putStrLn $ map snd $ cobenation 0 goatse
  134.  
Success #stdin #stdout 0s 4676KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
r()@m$3
r()@m$e
r()@mc3
r()@mce
r()@m53
r()@m5e
r()@ms3
r()@mse
r()@+$3
r()@+$e
r()@+c3
r()@+ce
r()@+53
r()@+5e
r()@+s3
r()@+se
r()@7$3
r()@7$e
r()@7c3
r()@7ce
r()@753
r()@75e
r()@7s3
r()@7se
r()@t$3
r()@t$e
r()@tc3
r()@tce
r()@t53
r()@t5e
r()@ts3
r()@tse
r()4m$3
r()4m$e
r()4mc3
r()4mce
r()4m53
r()4m5e
r()4ms3
r()4mse
r()4+$3
r()4+$e
r()4+c3
r()4+ce
r()4+53
r()4+5e
r()4+s3
r()4+se
r()47$3
r()47$e
r()47c3
r()47ce
r()4753
r()475e
r()47s3
r()47se
r()4t$3
r()4t$e
r()4tc3
r()4tce
r()4t53
r()4t5e
r()4ts3
r()4tse
r()am$3
r()am$e
r()amc3
r()amce
r()am53
r()am5e
r()ams3
r()amse
r()a+$3
r()a+$e
r()a+c3
r()a+ce
r()a+53
r()a+5e
r()a+s3
r()a+se
r()a7$3
r()a7$e
r()a7c3
r()a7ce
r()a753
r()a75e
r()a7s3
r()a7se
r()at$3
r()at$e
r()atc3
r()atce
r()at53
r()at5e
r()ats3
r()atse
r0@m$3
r0@m$e
r0@mc3
r0@mce
r0@m53
r0@m5e
r0@ms3
r0@mse
r0@+$3
r0@+$e
r0@+c3
r0@+ce
r0@+53
r0@+5e
r0@+s3
r0@+se
r0@7$3
r0@7$e
r0@7c3
r0@7ce
r0@753
r0@75e
r0@7s3
r0@7se
r0@t$3
r0@t$e
r0@tc3
r0@tce
r0@t53
r0@t5e
r0@ts3
r0@tse
r04m$3
r04m$e
r04mc3
r04mce
r04m53
r04m5e
r04ms3
r04mse
r04+$3
r04+$e
r04+c3
r04+ce
r04+53
r04+5e
r04+s3
r04+se
r047$3
r047$e
r047c3
r047ce
r04753
r0475e
r047s3
r047se
r04t$3
r04t$e
r04tc3
r04tce
r04t53
r04t5e
r04ts3
r04tse
r0am$3
r0am$e
r0amc3
r0amce
r0am53
r0am5e
r0ams3
r0amse
r0a+$3
r0a+$e
r0a+c3
r0a+ce
r0a+53
r0a+5e
r0a+s3
r0a+se
r0a7$3
r0a7$e
r0a7c3
r0a7ce
r0a753
r0a75e
r0a7s3
r0a7se
r0at$3
r0at$e
r0atc3
r0atce
r0at53
r0at5e
r0ats3
r0atse
6()@m$3
6()@m$e
6()@mc3
6()@mce
6()@m53
6()@m5e
6()@ms3
6()@mse
6()@+$3
6()@+$e
6()@+c3
6()@+ce
6()@+53
6()@+5e
6()@+s3
6()@+se
6()@7$3
6()@7$e
6()@7c3
6()@7ce
6()@753
6()@75e
6()@7s3
6()@7se
6()@t$3
6()@t$e
6()@tc3
6()@tce
6()@t53
6()@t5e
6()@ts3
6()@tse
6()4m$3
6()4m$e
6()4mc3
6()4mce
6()4m53
6()4m5e
6()4ms3
6()4mse
6()4+$3
6()4+$e
6()4+c3
6()4+ce
6()4+53
6()4+5e
6()4+s3
6()4+se
6()47$3
6()47$e
6()47c3
6()47ce
6()4753
6()475e
6()47s3
6()47se
6()4t$3
6()4t$e
6()4tc3
6()4tce
6()4t53
6()4t5e
6()4ts3
6()4tse
6()am$3
6()am$e
6()amc3
6()amce
6()am53
6()am5e
6()ams3
6()amse
6()a+$3
6()a+$e
6()a+c3
6()a+ce
6()a+53
6()a+5e
6()a+s3
6()a+se
6()a7$3
6()a7$e
6()a7c3
6()a7ce
6()a753
6()a75e
6()a7s3
6()a7se
6()at$3
6()at$e
6()atc3
6()atce
6()at53
6()at5e
6()ats3
6()atse
60@m$3
60@m$e
60@mc3
60@mce
60@m53
60@m5e
60@ms3
60@mse
60@+$3
60@+$e
60@+c3
60@+ce
60@+53
60@+5e
60@+s3
60@+se
60@7$3
60@7$e
60@7c3
60@7ce
60@753
60@75e
60@7s3
60@7se
60@t$3
60@t$e
60@tc3
60@tce
60@t53
60@t5e
60@ts3
60@tse
604m$3
604m$e
604mc3
604mce
604m53
604m5e
604ms3
604mse
604+$3
604+$e
604+c3
604+ce
604+53
604+5e
604+s3
604+se
6047$3
6047$e
6047c3
6047ce
604753
60475e
6047s3
6047se
604t$3
604t$e
604tc3
604tce
604t53
604t5e
604ts3
604tse
60am$3
60am$e
60amc3
60amce
60am53
60am5e
60ams3
60amse
60a+$3
60a+$e
60a+c3
60a+ce
60a+53
60a+5e
60a+s3
60a+se
60a7$3
60a7$e
60a7c3
60a7ce
60a753
60a75e
60a7s3
60a7se
60at$3
60at$e
60atc3
60atce
60at53
60at5e
60ats3
60atse
9()@m$3
9()@m$e
9()@mc3
9()@mce
9()@m53
9()@m5e
9()@ms3
9()@mse
9()@+$3
9()@+$e
9()@+c3
9()@+ce
9()@+53
9()@+5e
9()@+s3
9()@+se
9()@7$3
9()@7$e
9()@7c3
9()@7ce
9()@753
9()@75e
9()@7s3
9()@7se
9()@t$3
9()@t$e
9()@tc3
9()@tce
9()@t53
9()@t5e
9()@ts3
9()@tse
9()4m$3
9()4m$e
9()4mc3
9()4mce
9()4m53
9()4m5e
9()4ms3
9()4mse
9()4+$3
9()4+$e
9()4+c3
9()4+ce
9()4+53
9()4+5e
9()4+s3
9()4+se
9()47$3
9()47$e
9()47c3
9()47ce
9()4753
9()475e
9()47s3
9()47se
9()4t$3
9()4t$e
9()4tc3
9()4tce
9()4t53
9()4t5e
9()4ts3
9()4tse
9()am$3
9()am$e
9()amc3
9()amce
9()am53
9()am5e
9()ams3
9()amse
9()a+$3
9()a+$e
9()a+c3
9()a+ce
9()a+53
9()a+5e
9()a+s3
9()a+se
9()a7$3
9()a7$e
9()a7c3
9()a7ce
9()a753
9()a75e
9()a7s3
9()a7se
9()at$3
9()at$e
9()atc3
9()atce
9()at53
9()at5e
9()ats3
9()atse
90@m$3
90@m$e
90@mc3
90@mce
90@m53
90@m5e
90@ms3
90@mse
90@+$3
90@+$e
90@+c3
90@+ce
90@+53
90@+5e
90@+s3
90@+se
90@7$3
90@7$e
90@7c3
90@7ce
90@753
90@75e
90@7s3
90@7se
90@t$3
90@t$e
90@tc3
90@tce
90@t53
90@t5e
90@ts3
90@tse
904m$3
904m$e
904mc3
904mce
904m53
904m5e
904ms3
904mse
904+$3
904+$e
904+c3
904+ce
904+53
904+5e
904+s3
904+se
9047$3
9047$e
9047c3
9047ce
904753
90475e
9047s3
9047se
904t$3
904t$e
904tc3
904tce
904t53
904t5e
904ts3
904tse
90am$3
90am$e
90amc3
90amce
90am53
90am5e
90ams3
90amse
90a+$3
90a+$e
90a+c3
90a+ce
90a+53
90a+5e
90a+s3
90a+se
90a7$3
90a7$e
90a7c3
90a7ce
90a753
90a75e
90a7s3
90a7se
90at$3
90at$e
90atc3
90atce
90at53
90at5e
90ats3
90atse
g()@m$3
g()@m$e
g()@mc3
g()@mce
g()@m53
g()@m5e
g()@ms3
g()@mse
g()@+$3
g()@+$e
g()@+c3
g()@+ce
g()@+53
g()@+5e
g()@+s3
g()@+se
g()@7$3
g()@7$e
g()@7c3
g()@7ce
g()@753
g()@75e
g()@7s3
g()@7se
g()@t$3
g()@t$e
g()@tc3
g()@tce
g()@t53
g()@t5e
g()@ts3
g()@tse
g()4m$3
g()4m$e
g()4mc3
g()4mce
g()4m53
g()4m5e
g()4ms3
g()4mse
g()4+$3
g()4+$e
g()4+c3
g()4+ce
g()4+53
g()4+5e
g()4+s3
g()4+se
g()47$3
g()47$e
g()47c3
g()47ce
g()4753
g()475e
g()47s3
g()47se
g()4t$3
g()4t$e
g()4tc3
g()4tce
g()4t53
g()4t5e
g()4ts3
g()4tse
g()am$3
g()am$e
g()amc3
g()amce
g()am53
g()am5e
g()ams3
g()amse
g()a+$3
g()a+$e
g()a+c3
g()a+ce
g()a+53
g()a+5e
g()a+s3
g()a+se
g()a7$3
g()a7$e
g()a7c3
g()a7ce
g()a753
g()a75e
g()a7s3
g()a7se
g()at$3
g()at$e
g()atc3
g()atce
g()at53
g()at5e
g()ats3
g()atse
g0@m$3
g0@m$e
g0@mc3
g0@mce
g0@m53
g0@m5e
g0@ms3
g0@mse
g0@+$3
g0@+$e
g0@+c3
g0@+ce
g0@+53
g0@+5e
g0@+s3
g0@+se
g0@7$3
g0@7$e
g0@7c3
g0@7ce
g0@753
g0@75e
g0@7s3
g0@7se
g0@t$3
g0@t$e
g0@tc3
g0@tce
g0@t53
g0@t5e
g0@ts3
g0@tse
g04m$3
g04m$e
g04mc3
g04mce
g04m53
g04m5e
g04ms3
g04mse
g04+$3
g04+$e
g04+c3
g04+ce
g04+53
g04+5e
g04+s3
g04+se
g047$3
g047$e
g047c3
g047ce
g04753
g0475e
g047s3
g047se
g04t$3
g04t$e
g04tc3
g04tce
g04t53
g04t5e
g04ts3
g04tse
g0am$3
g0am$e
g0amc3
g0amce
g0am53
g0am5e
g0ams3
g0amse
g0a+$3
g0a+$e
g0a+c3
g0a+ce
g0a+53
g0a+5e
g0a+s3
g0a+se
g0a7$3
g0a7$e
g0a7c3
g0a7ce
g0a753
g0a75e
g0a7s3
g0a7se
g0at$3
g0at$e
g0atc3
g0atce
g0at53
g0at5e
g0ats3
g0atse
https://ideone.com/PkN4mv
language:
Haskell (ghc 8.4.4)
created:
10 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!