[Haskell-cafe] Re: Red-Blue Stack

[jean verdier]

I'm a haskell beginner so the following code might not meet haskell
coding standards. I think that it is a correct O(1) implementation.
Sorry if i simply recoded an already posted solution that i did not
understand correctly.

--- code ---------
module Main where

data Col a
  = Red a
  | Blue a

data RBStack a = 
  RBS [Col Int]  -- order
      [a]        -- blues
      [a]        -- reds 

empty = RBS [] [] []

push (Blue e) (RBS []            [] [])   
  = RBS [Blue 1]          [e]    []
push (Blue e) (RBS ((Blue n):ns) bs rs)   
  = RBS ((Blue (n+1)):ns) (e:bs) rs
push (Blue e) (RBS ns            bs rs)   
  = RBS ((Blue 1):ns)     (e:bs) rs
push (Red e)  (RBS []            [] [])   
  = RBS [Red 1]           []     [e]
push (Red e)  (RBS ((Red n):ns)  bs rs)   
  = RBS ((Red (n+1)):ns)  bs     (e:rs)
push (Red e)  (RBS ns            bs rs)   
  = RBS ((Red 1):ns)      bs     (e:rs)

popBlue (RBS [] _ _)                                    
  = error "no blue, empty stack"
popBlue (RBS [Red _] _ _)                               
  = error "no blue"
popBlue (RBS ((Red nr):(Blue 1):[]) [b] rs)             
  = RBS [Red nr]                   [] rs
popBlue (RBS ((Red nr):(Blue 1):(Red nr'):s) (b:bs) rs) 
  = RBS ((Red (nr+nr')):s)         bs rs
popBlue (RBS ((Red nr) :(Blue nb):s) (b:bs) rs)         
  = RBS ((Red nr):(Blue (nb-1)):s) bs rs
popBlue (RBS ((Blue 1):s) (b:bs) rs)                    
  = RBS s                          bs rs
popBlue (RBS ((Blue nb):s) (b:bs) rs)                   
  = RBS (Blue (nb-1):s)            bs rs

popRed (RBS [] _ _)                                     
  = error "no red, empty stack"
popRed (RBS [Blue _] _ _)                               
  = error "no red"
popRed (RBS ((Blue nb):(Red 1):[]) bs [r])              
  = RBS [Blue nb]                  bs []
popRed (RBS ((Blue nb):(Red 1):(Blue nb'):s) bs (r:rs)) 
  = RBS ((Blue (nb+nb')):s)        bs rs
popRed (RBS ((Blue nb):(Red nr):s) bs (r:rs))           
  = RBS ((Blue nb):(Red (nr-1)):s) bs rs
popRed (RBS ((Red 1):s) bs (r:rs))                      
  = RBS s                          bs rs
popRed (RBS ((Red nr):s) bs (r:rs))                     
  = RBS (Red (nr-1):s)             bs rs

pop (RBS [] _ _)               = error "empty stack"
pop rbs@(RBS ((Red _):_) _ _)  = popRed rbs
pop rbs@(RBS ((Blue _):_) _ _) = popBlue rbs

pp (RBS [] [] []) = ""
pp (RBS ((Red 1):s) bs (r:rs)) 
  = "r " ++ (pp (RBS s bs rs))
pp (RBS ((Red n):s) bs (r:rs)) 
  = "r " ++ (pp (RBS ((Red (n-1)):s) bs rs))
pp (RBS ((Blue 1):s) (b:bs) rs) 
  = "b " ++ (pp (RBS s bs rs))
pp (RBS ((Blue n):s) (b:bs) rs) 
  = "b " ++ (pp (RBS ((Blue (n-1)):s) bs rs))

altPushRed  0 = empty
altPushRed  n = push (Red n) (altPushBlue (n-1))
altPushBlue 0 = empty
altPushBlue n = push (Blue n) (altPushRed (n-1))

main = do
  let s = altPushRed 4
      s1 = popBlue $ popBlue $ s
      s2 = popRed $ popRed $ s
      s3 = pop $ pop $ s
  putStrLn ("s  = " ++ (pp s))
  putStrLn ("s1 = " ++ (pp s1))
  putStrLn ("s2 = " ++ (pp s2))
  putStrLn ("s3 = " ++ (pp s3))