Wuchty 98: Basic RNA secondary structure prediction
ADP Source Code Try DP online
Haskell header: showcode
> module Wuchty98 where

> import Array
> import List
> import RnaI
> import ADPTriCombinators
The signature: showcode
> data Closed = 
>     Str Closed              |
>     Ss Region               |
>     Hl Char Region Char     |
>     Sr Char Closed Char     | 
>     Bl  Region Closed       | 
>     Br Closed Region        | 
>     Il Region Closed Region |
>     Ml Char Closed Char     | 
>     Blk Region Closed       | 
>     Nil ()                  |
>     Cons Closed Closed      | 
>     Ul Closed
>                   deriving (Show, Eq, Ord)
The yield grammar: showcode
> wuchty98 alg inp = axiom struct where
>  (str,ss,hl,sr,bl,br,il,ml,blk,nil,cons,ul,h) = alg

>  struct       =  str  <<< comps                            ||| 
>                  str  <<< (ul  <<< singlestrand)           |||
>                  str  <<< (nil <<< empty)                  ... h

>  block        = tabulated(
>                           strong                           ||| 
>                  blk  <<< region ~~~ strong                ... h)

>  comps        = tabulated(
>                  cons <<< block  ~~~ comps                 ||| 
>                  ul   <<< block                            |||
>                  cons <<< block  ~~~ (ul <<< singlestrand) ... h)

>  singlestrand =  ss   <<< region

>  strong       = tabulated(
>                  (sr  <<< base -~~ strong  ~~- base |||
>                   sr  <<< base -~~  weak   ~~- base)
>                       `with` basepairing                   ... h)
>  weak         = tabulated(
>                   (hl <<< base -~~          region3             ~~- base  |||
>                    sr <<< base -~~ (bl   <<< region ~~~ strong) ~~- base  |||
>                    sr <<< base -~~ (br   <<< strong ~~~ region) ~~- base  ||| 
>                    ml <<< base -~~ (cons <<< block  ~~~ comps ) ~~- base  |||
>                    sr <<< base -~~ (il   <<< region ~~~ strong  ~~~ region) ~~- base) 
>                       `with` basepairing                    ... h) 

>  region3 = region `with` (minsize 3)
Bind input: showcode
>  axiom        = axiom' n
>  z            = mk (inp)
>  (_,n)        = bounds z
>  base         = achar' z

>  region (i,j) = [(i,j) | i < j]
>  tabulated    = table n

>  minsize :: Int -> Filter
>  minsize n = match inp where
>    match inp (i,j) = i+n<=j

>  basepairing :: Filter
>  basepairing  = match inp where
>    match inp (i,j) = i+1<j && basepair (z!(i+1), z!(j))
>  basepair ('a','u') = True
>  basepair ('u','a') = True
>  basepair ('c','g') = True
>  basepair ('g','c') = True
>  basepair ('g','u') = True
>  basepair ('u','g') = True
>  basepair ( x , y ) = False
Enumeration algebra: showcode
> enum :: Algebra Char Region Closed
> enum = (str, ss, hl, sr, bl, br, il, ml, blk, nil, cons, ul, h) where
>    str  = Str
>    ss   = Ss
>    hl   = Hl
>    sr   = Sr
>    bl   = Bl
>    br   = Br
>    il   = Il
>    ml   = Ml
>    blk  = Blk
>    nil  = Nil
>    cons = Cons
>    ul   = Ul
>    h    = id
Pretty printing algebra: showcode
> pretty_gen :: ([String] -> [String]) -> Algebra Char Region String
> pretty_gen h = (str, ss, hl, sr, bl, br, il, ml, blk, nil, cons, ul, h) where
>    str s            = s
>    ss r             = dots r
>    hl _ r _         = '(': dots r ++ ")"
>    sr _   s   _     = '(':      s ++ ")"   
>    bl  r s          = dots r ++ s
>    br s r           = s ++ dots r 
>    il r1 s r2       = dots r1 ++ s ++ dots r2
>    ml _   s   _     = '(':      s     ++ ")"   
>    blk r s          = dots r ++ s
>    nil _            = " "
>    cons a b         = a ++ b
>    ul s             = s

>    dots (i,j) = replicate (j-i) '.'

> pretty :: Algebra Char Region String
> pretty = pretty_gen id

> pretty' :: Algebra Char Region String
> pretty' = pretty_gen h where
>    h []     = []
>    h xs     = [minimum xs]
Shape algebra: showcode
> shape :: String ->   -- loop singlestrand
>          String ->   -- loop opening
>          String ->   -- loop closing
>          String ->   -- singlestrand
>          Algebra Char Region String

> shape loop_ss loop_op loop_cl singlestrand = 
>   (str, ss, hl, sr, bl, br, il, ml, blk, nil, cons, ul, h) where
>   str s        = s
>   ss _         = singlestrand
>   hl _ _ _     = "[" ++ loop_ss ++ "]"
>   sr _ s _     = s
>   bl _ s       = loop_op++loop_ss++s++loop_cl
>   br s _       = loop_op++s++loop_ss++loop_cl
>   il _ s _     = loop_op++loop_ss++s++loop_ss++loop_cl
>   ml _ s _     = '[':s++"]"
>   blk _ s      = loop_ss++s
>   nil _        = ""  
>   cons s1 s2   = if (head' s2 == singlestrand && 
>                      head' (reverse s1) == singlestrand) 
>                  then s1 ++ tail' s2 else s1++s2
>   ul s         = s
>   h            = nub

>   head' [] = []
>   head' x  = [head x]
>   tail' [] = []
>   tail' x  = tail x

> shape1 = shape "_" "[" "]" "_"
> shape2 = shape "" "[" "]" "_"
> shape3 = shape "_" "" "" "_"
> shape4 = shape "" "" "" ""
Counting Algebra: showcode
> count :: Algebra Char Region Int
> count = (str, ss, hl, sr, bl, br, il, ml, blk, nil, cons, ul, h) where
>    str a = a
>    ss a = 1
>    hl a b c = 1
>    sr a b c = b
>    bl a b = b
>    br a b = a
>    il a b c = b
>    ml a b c = b
>    blk a b = b
>    nil a = 1
>    cons a b = a * b
>    ul a = a
>    h [] = []
>    h xs = [sum xs]
Basepair maximization algebra: showcode
> bpmax_gen :: ([Int] -> [Int]) -> Algebra Char Region Int
> bpmax_gen h = (str, ss, hl, sr, bl, br, il, ml, blk, nil, cons, ul, h) where
>    str a    = a
>    ss _     = 0
>    hl _ _ _ = 1
>    sr _ s _ = s + 1
>    bl _ s   = s
>    br s _   = s
>    il _ s _ = s
>    ml _ s _ = s + 1
>    blk _ s  = s
>    nil _    = 0
>    cons a b = a + b
>    ul s     = s

> bpmax :: Algebra Char Region Int
> bpmax = bpmax_gen h where
>    h []     = []
>    h xs     = [maximum xs]

> bpmax_k :: Int -> Algebra Char Region Int
> bpmax_k k = bpmax_gen h where
>    h = take k . sortBy (flip compare) . nub
Stacking base pair maximization algebra: showcode
> spmax_gen :: ([Int] -> [Int]) -> Algebra Char Region Int
> spmax_gen h = (str, ss, hl, sr, bl, br, il, ml, blk, nil, cons, ul, h) where
>    str a    = a
>    ss _     = 0
>    hl _ _ _ = 0
>    sr _ s _ = s + 1
>    bl _ s   = s - 1
>    br s _   = s - 1
>    il _ s _ = s - 1
>    ml _ s _ = s + 1
>    blk _ s  = s 
>    nil _    = 0
>    cons a b = a + b
>    ul s     = s

> spmax :: Algebra Char Region Int
> spmax = spmax_gen h where
>    h []     = []
>    h xs     = [maximum xs]

> spmax_k :: Int -> Algebra Char Region Int
> spmax_k k = spmax_gen h where
>    h = take k . sortBy (flip compare) . nub
Algebra type: showcode
> type Algebra alph region answer = (
>    answer -> answer,                      -- str
>    region -> answer,                      -- ss
>    alph -> region -> alph -> answer,      -- hl
>    alph -> answer -> alph -> answer,      -- sr
>    region -> answer -> answer,            -- bl
>    answer -> region -> answer,            -- br
>    region -> answer -> region -> answer,  -- il
>    alph -> answer -> alph -> answer,      -- ml
>    region -> answer -> answer,            -- blk
>    () -> answer,                          -- nil
>    answer -> answer -> answer,            -- cons
>    answer -> answer,                      -- ul
>    [answer] -> [answer])                  -- h
Algebra cross product: showcode
> infix ***
> alg1 *** alg2 = (str, ss, hl, sr, bl, br, il, ml, blk, nil, cons, ul, h) where
>    (str1, ss1, hl1, sr1, bl1, br1, il1, ml1, blk1, nil1, cons1, ul1, h1) = alg1
>    (str2, ss2, hl2, sr2, bl2, br2, il2, ml2, blk2, nil2, cons2, ul2, h2) = alg2

> 
>    str (a1,a2) = (str1 a1, str2 a2)
>    ss a = (ss1 a, ss2 a)
>    hl a b c = (hl1 a b c, hl2 a b c)
>    sr a (b1,b2) c = (sr1 a b1 c, sr2 a b2 c)
>    bl a (b1,b2) = (bl1 a b1, bl2 a b2)
>    br (a1,a2) b = (br1 a1 b, br2 a2 b)
>    il a (b1,b2) c = (il1 a b1 c, il2 a b2 c)
>    ml a (b1,b2) c = (ml1 a b1 c, ml2 a b2 c)

>    blk a (b1,b2) = (blk1 a b1, blk2 a b2)
>    nil a = (nil1 a, nil2 a)
>    cons (a1,a2) (b1,b2) = (cons1 a1 b1, cons2 a2 b2)
>    ul (a1,a2) = (ul1 a1, ul2 a2)
 
>    h xs = [(x1,x2)| x1 <- nub $ h1 [ y1 | (y1,y2) <- xs],
>                     x2 <-       h2 [ y2 | (y1,y2) <- xs, y1 == x1]]
For usage on your local machine:
background image
university bielefeld AG PI BiBiServ
ambient picture