state.scm

;;state :: s -> (a s)

(define (map-state f st)
  (lambda (x)
    (let* ((res (st x))
          (a (car res))
          (s (cadr res)))
      (state (f a) s))))

(define (pure a)
  (lambda (s) (list a s)))

(define (bind-state st f)
  (lambda (s)
    (let* ((res (st s))
          (a (car res))
          (newState (cadr res))
          (g (f a)))
      (g newState))))


;;helper functions
(define get
  (lambda (s) (state s s)))

(define get-s
  (lambda (s) (cadr (state s s))))

(define (put newState)
  (lambda (s) (state 'nothing s)))

(define (state a s) (list a s))

;;stack state
(define pop
  (lambda (xs) (state (car xs) (cdr xs))))

(define (push a)
  (lambda (xs) (state 'nothing (cons a xs))))


(define >>= bind-state)

(define (>> m k)
  (bind-state m (lambda (_) k)))
  

(define stack-state1
  (bind-state (push 3)
              (lambda (x) (bind-state pop
                                      (lambda (y)
                                        pop)))))

(define stack-state2
  (>> (push 3)
      (>> pop
          (>> pop
              (push 0)))))
          
(define stack-state3
  (>>= pop
       (lambda (x)
         (if (= x 5)
             (push 55)
             (push 0)))))

(stack-state1 '(5 6 7))
(stack-state2 '(5 6 7))
(stack-state3 '(5 6 7))
(stack-state3 '(6 7 8))

;(5 (6 7))
;(nothing (0 6 7))
;(nothing (55 6 7))
;(nothing (0 7 8))
       

;;label all leafs in a tree with a unique number

(define inc
  (lambda (s) (state s (+ s 1))))
      
(define (label-tree xs)
  (cond ((null? xs) (pure '()))
        ((pair? (car xs))
         (>>= (label-tree (car xs))
              (lambda (head)
                (>>= (label-tree (cdr xs))
                     (lambda (tail)
                       (pure (cons head tail)))))))
        (else
         (>>= inc
              (lambda (count)
                (>>= (label-tree (cdr xs))
                     (lambda (tree) (pure (cons (cons (car xs) count)
                                                tree)))))))))

(define (run-label-tree xs)
  ((label-tree xs) 0))

(run-label-tree '())
(run-label-tree '(a b c d e f))
(run-label-tree '(a b (c (d)) e f))


;;med applicatives, eller bare liftA2 (liftA2 f a b = pure f <*> a <*> b
;;applicatives (som alt annet) er mye nicere med currying, men
;;det ble en veldig forbedring over monad-versjonen (uten do-notation)

(define (<*> fs as)
  (>>= fs
       (lambda (f)
         (>>= as
              (lambda (a)
                (pure (f a)))))))

(define (liftA2 f as bs)
  (>>= as
       (lambda (a)
         (>>= bs
              (lambda (b)
                (pure (f a b)))))))


(define (label-tree xs)
  (cond ((null? xs) (pure '()))
        ((pair? (car xs))
         (liftA2 cons
                 (label-tree (car xs))
                 (label-tree (cdr xs))))
        (else
         (>>= inc
              (lambda (count)
                (liftA2 cons
                        (pure (cons (car xs) count))
                        (label-tree (cdr xs))))))))

(run-label-tree '())
(run-label-tree '(a b c d e f))
(run-label-tree '(a b (c (d)) e f))



;;traverse :: (a -> State s b) -> Tree a -> State s (Tree b)
;;generaliserer traversering, som label-tree. 

(define (traverse-tree f xs)
  (cond ((null? xs) (pure '()))
        ((pair? (car xs))
         (liftA2 cons
                 (traverse-tree f (car xs))
                 (traverse-tree f (cdr xs))))
        (else 
                (liftA2 cons
                        (f (car xs))
                        (traverse-tree f (cdr xs))))))

(define (label x)
  (>>= inc
       (lambda (i)
         (pure (cons x i)))))

((traverse-tree label '(a b (c (d)) e f)) 0)


;;shift every leaf to the right
(define (shift p)
  (lambda (s) (state s p)))

((traverse-tree shift '(a b (c (d)) e f)) 'start)