vl_15_1_2015

(ns repl.core
  (:use clojure.algo.monads))

(declare $assign $int $id $postinc $add $postinc $do'
         m-assign m-int m-id m-postinc m-add m-do)

(comment


  ;; Monaden

  ;; Abstraktion für Komposition von Funktionen


  (defn foo [n] (range n))
  (defn bar [x] [x (* x x)])

  ((comp foo bar) 5)

  (defn foobar [n] (domonad sequence-m [ a (m-result n)
                                        b (foo a)
                                        c (bar b)] c))

  (foobar 5)


  ;; domonad sequence-m ist im Grunde nur for

  (defn foobar [n] (for [ a [n] b (foo a) c (bar b)] c))
  (foobar 5)


  ;; domonad heist monad comprehension und ist im Grunde eine Art
  ;; abstraktes let oder for. Das Verhalten der comprehension wird
  ;; durch die beiden Funktionen bind und return bestimmt.

  ;; bind ist ein Kompositionsoperator
  ;; return "verpackt" einen Wert in einen Kontext

  ;; Ein Wert mit Kontext heisst monadischer Wert
  ;; Eine Funktion von Wert nach monadischer Wert heisst monadische
  ;; Funktion

  ;; Wenn bind und return bestimmte Regeln erfüllen, dann bilden sie
  ;; die Monade und verhalten sich automatisch gutartig bei höheren
  ;; Monadenfunktionen.

  ;; return ist neutrales Element bzgl. bind
  ;; bind ist assoziativ


  (defn seq-bind [mv f] (mapcat f mv))
  (def seq-return list)

  (seq-bind
   (seq-bind
    (seq-return 5)
    foo)
   bar)

  (mapcat bar (mapcat foo [5]))

  ;; bind: Funktion die einen monadischen Wert und eine monadische
  ;; Funktion als Parameter bekommt und einen monadischen Wert zurückgibt

  ;; return: Monadische Funktion, die einen normalen Wert als
  ;; Parameter bekommt und einen monadischen Wert zurückgibt


  ;; Wir kennen:
  ;; Maybe (Berechnungen, die fehlschlagen können)
  ;; Trivial (gewöhnliche Berechnung)
  ;; Sequence (nichtdeterministische Berechnung)
  ;; State (Berechnung mit Zustand)

  ;; Es gibt mehr:

  ;; Set: Wie Sequence ohne Wiederholungen
  ;; Frage: Wie sehen bind und return aus?


  ;; Reader: State ohne Schreiben
  ;; Continuations: CPS Berechnungen

  ;; Continuation Passing Style

  (defn foo [v f]
    (f (inc v)))

  (foo 3 #(* % 2))

  ;; Bei Interesse: http://www.clojure.net/2012/03/24/Continuation-monad/


  ;; und noch mehr ... Either, Parser, Writer, Backtracking,
  ;; Random numbers, BFS, DFS, Quantum Computing, ...
  ;; Die sind nicht in algo.monads enthalten


  ;; Higher Order Funktionen

  ;; m-chain bekommt eine Liste mit monadischen Funktionen und liefert
  ;; eine Funktion, die einen Initialwert nimmt und die monadischen
  ;; Funktionen in Reihe ausführt

  ;; (m-chain [f1 f2]) ist äquivalent zu
  ;; (fn [x] (domonad [a (f1 x) b (f2 a)] b))

  (defn unscharf [x] [(inc x) (dec x)])

  (def tripple-unscharf
    (with-monad sequence-m
      (m-chain (repeat 3 unscharf))))

  (tripple-unscharf 10)

  ;; Es gibt auch m-until, das ein Prädikat zum Abbruch benutzt (s.
  ;; Übung von heute morgen)

  (defn s-div [a b] (when (not= 0 b) (/ a b)))

  ;; m-reduce [mf coll]
  ;; reduce mit geliftetem mf auf coll

  (with-monad maybe-m
    (m-reduce s-div [800 2 1/2 2 0 3]))

  (with-monad maybe-m
    (m-reduce s-div 800 [2 4]))

  ;; m-map
  (with-monad maybe-m
    (m-map (partial s-div 100) [2 3 4 8]))

  (with-monad maybe-m
    (m-map (partial s-div 100) [2 3 0 8]))

  (with-monad sequence-m
    (m-map unscharf [1 2 3]))

  ;; m-seq
  (with-monad sequence-m
    (m-seq [[1 2] [3 4] [5 6]]))





  ;; State Monade im Beispiel:

  ;; Es soll ein Interpreter für eine (sehr einfache) Sprache
  ;; geschrieben werden:

  ;; x = 4
  ;; y = x++ + x

  ;; Ein Parser soll dafür schon existieren und folgende Datenstruktur
  ;; generieren

  (def input '($do ($assign :x ($int 4))
                   ($assign :y
                            ($add ($postinc :x)
                                  ($id :x)))))



  ;; Aufgabe: Schreibe einen Interpreter für die Sprache
  ;; Das Ergebnis des Programmaufrufs soll 9 sein!
  ;; Der Typ jeder Variablen ist Long. Der Default-Wert einer nicht
  ;; gesetzten Variable ist 0.


  ;; Zeit: 10 Minuten














  (def state (ref {}))
  (def $int identity)
  (defn $id [n] (dosync (get @state n 0)))
  (def $add +)
  (defn $postinc [n]
    (dosync (let [v (get @state n 0)]
              (alter state (fn [s] (assoc s n (inc v))))
              v)))
  (defn $assign [n v] (dosync (alter state (fn [s] (assoc s n v))) nil))
  (defn $do [a b] b)

  (eval input)
  @state



  ;; Wie kann man das testen?

  ;; Nicht gut!

  (defn test1 []
    (dosync (let [s @state]
              (alter state (constantly {:x 1}))
              ($postinc :x)
              (assert (= 2 (get @state :x)))
              (alter state (constantly s)))))

  (do  (test1) state)

  ;;Es wäre besser, wenn die Funktionen den State explizit
  ;; als Eingabe bekommen würden.

  (defn $postinc' [e n] (let [v (get e n)] [v (assoc e n (inc v))]))

  (defn test2 [x]
    (= ($postinc' {:x x} :x) [1 {:x 2}]))

  (test2 1)
  (test2 2)


  ;; Von Hand wird das ziemlich aufwändig! Insbesondere müssen wir den
  ;; Input ändern

  ;; state-m to the rescue

  (def xx state-m)

  ;; Umbenennung nur zur Klarheit hier. Es wäre auch mit dem Original gegangen!
  (def m-input '(m-do (m-assign :x (m-int 4))
                      (m-assign :y
                                (m-add (m-postinc :x)
                                       (m-id :x)))))


  (with-monad xx
    (def m-int m-result)
    (def m-id fetch-val)
    (def m-add (m-lift 2 +))
    (defn m-postinc [k]
      (domonad
       [x (fetch-val k)
        y (set-val k (inc x))] y))

    (defn m-assign [n mv]
      (domonad [v mv
                r (set-val n v)] r))
    (defn m-do [a b] (domonad [x a y b] b))

    )


  (def compiled (eval m-input))

  (compiled {:x 2})

  (defn swap [a b]
    (m-do
     (m-do (m-assign :t (m-id a))
           (m-assign a (m-id b)))
     (m-assign b (m-id :t))))

  ((swap :x :y) {:x 1 :y 3 :z 5})


  (with-monad xx
    (def m-div (m-lift 2 (fn [a b] (when-not (zero? b) (/ a b))))))


  (defn p [d1] (m-assign :p (m-div (m-id :p) (m-int d1))))

  ((p 2) {:p 6})

  ((m-do (p 2) (p 3)) {:p 30})

  ((m-do (p 0) (p 3)) {:p 30})


  (def xy (maybe-t state-m))


  (with-monad xy
    (def m-int m-result)
    (def m-id fetch-val)
    (def m-add (m-lift 2 +))
    (defn m-postinc [k]
      (domonad
       [x (fetch-val k)
        y (set-val k (inc x))] y))

    (defn m-assign [n mv]
      (domonad [v mv
                r (set-val n v)] r))
    (defn m-do [a b] (domonad [x a y b] b))
    (def m-div (m-lift 2 (fn [a b] (when-not (zero? b) (/ a b)))))
    )

  ((m-do (p 2) (p 3)) {:p 30})
  ((m-do (p 0) (p 3)) {:p 30})


  ;; Monaden sind auch Konzepte in der Kathegorientheorie. Es steckt
  ;; also noch eine ganze Menge mehr Theorie dahinter.


  ;; ---------------------------------------------------------

  ;; Funktionales Refactoring

  ;; 1. Verpacken eines Ausdrucks in einer Funktion und sofortiges Aufrufen ändert nichts
  ;; am Ergebnis

  2

  ((fn [] 5))

  ((fn [x] (* 3 x)) 11)

  ((fn []
     ((fn [x] (* 3 x)) 12)
     ))

  (
   ((fn [] (fn [x] (* 3 x))))
   13)

  (
   ((fn [] (fn [x] (*
                    ((fn [] 3))
                    x))))
   14)


  ;; 2. Das geht auch mit Parametern aka. Binding einführen

  (def x 1)
  ((fn [] x))
  ((fn [y] x) :foo)

  ;; Was muss man beachten?










  ;; Immer frische Variablen benutzen
  ((fn [x] x) :blah)



  ;; 3. Wrapping


  (defn mk-adder [x]
    (println :call)
    (fn [n] (+ x n)))

  (def add1 (mk-adder 1))
  (add1 3)

  (defn mk-adder' [x]
    (fn [v] ((mk-adder x) v)))

  (def add1' (mk-adder' 1))

  (add1' 2)



  ;; 4. Inline Definition
  (def foo1 (fn [n] (+ 1 n)))
  (def foo2 (fn [x] (foo1 x)))
  (def foo3 (fn [x] ((fn [n] (+ x n)) x)))

  (foo2 2)


  ;; lambda-Kalkül und Rekursion


  ;; Erinnerung:
  ;; Expr ::== Var | lambda Var.Expr | Expr Expr

  ;; Der Einfachheit halber kann man konstante Werte (z.B. Zahlen) und
  ;; Arithmetik hinzufügen.

  ;; alpha Konversion
  ;; Umbenennung von Variablen durch frische Variablen
  (fn [x] (+ a x))
  (fn [y] (+ a y))

  ;;; falsch:
  (fn [a] (+ a a))

  ;; beta-Reduktion
  ;; Bei der Funktionsanwendung lambdav.E F wird der Ausdruck lambdav.E durch E
  ;; ersetzt, wobei v durch F ersetzt wird.

  ;; E = (+ 3 x), F = 5
  ((fn [x] (+ x 3)) 5)
  (+ 3 5)

  ;; E = (+ 3 z), F = (fn [y] (* x y))
  ((fn [z] (+ 3 z)) (fn [y] (* x y)))
  (+ 3 (fn [y] (* x y)))
  ;; Es ist ein rein formaler, ungetypter  Kalkül, man kan durchaus
  ;; Unfug schreiben!


  ;; Aufgabe: Führe einen Reduktionsschritt durch:
  ((fn [x] (x x)) (fn [y] (y y)))











  ((fn [y] (y y)) (fn [y] (y y)))

  ;; Bis auf alpha Konversion ist das der gleiche Ausdruck!
  ;; Ergo:  ((fn [x] (x x)) (fn [y] (y y))) ist ein Fixpunkt bzgl. der
  ;; beta Reduktion


  ;; Rekursion:

  (def fact
    (fn [n]
      (if (= 1 n)
        1
        (* n (fact (dec n))))))

  (fact 3)

  ;; Wie  wird das berechnet?

  ;; Inlining
  ((fn [n] (if (= 1 n) 1 (* n (fact (dec n))))) 3)
  ;; beta-Reduction
  (if (= 1 3) 1 (* 3 (fact (dec 3))))
  (* 3 (fact 2))

  ;; Inlining
  (* 3 ((fn [n] (if (= 1 n) 1 (* n (fact (dec n))))) 2))
  ;; beta-Reduction
  (* 3 (if (= 1 2) 1 (* 2 (fact (dec 2)))))
  (* 3 (* 2 (fact 1)))
  ;; Inlining
  (* 3 (* 2 ((fn [n] (if (= 1 n) 1 (* 1 (fact (dec n))))) 1)))
  ;; beta-Reduction
  (* 3 (* 2 (if (= 1 1) 1 (* 1 (fact (dec n))))))
  (* 3 (* 2 1))

  ;; Wie kann man das im lambda-Kalkül (mit Zahlen und Arithmetik)
  ;; ausdrücken?


  ;; Problem: Es gibt nur anonyme Funktionen?

  ;; angenommen partial-fact löst das Problem für n-1, dann produziert
  ;; improve-fact eine Lösung des Problems für n:

  (def improve-fact
    (fn [partial-fact]
      (fn [n] (if (= 1 n) 1 (* n (partial-fact (dec n)))))))

  ;; Angenommen partial-fact ist die fact Funktion, dann gibt
  ;; improve-fact auch die fact Funktion zurück.

  ;; inprove-fact(fact) = fact


  ;; Was sagt uns das?


  (defn bumm! [_] (throw (Exception. "Kaboom!")))

  (def f1 (improve-fact bumm!))

  (f1 1)
  (f1 2)

  (def f2 (improve-fact f1))
  (f2 1)
  (f2 2)
  (f2 3)

  (def f3 (improve-fact f2))
  (f3 3)
  (f3 4)

  ;; So ganz das Gelbe vom Ei ist das noch nicht!

  ;; Es folgen einige Refactorings ausgehend von f2

  (def f2 (improve-fact (improve-fact bumm!)))

  ;; Refactoring 1: Wrapping

  (def f2 (
           (fn [improver] (improver (improver bumm!)))
           improve-fact))

  (f2 2)
  (f2 3)

  ;; Inlining von improve_fact

  (def f2 (
           (fn [improver] (improver (improver bumm!)))
           (fn [partial-fact]
             (fn [n] (if (= 1 n) 1 (* n (partial-fact (dec n))))))))

  ;; bumm! hat eigentlich nichts mit der Fakultät zu tun
  ;; Kann man das entfernen?

  (def f2 (
           (fn [improver] (improver improver))
           (fn [partial-fact]
             (fn [n] (if (= 1 n) 1 (* n (partial-fact (dec n))))))))

  (f2 1)
  (f2 2)


  ;; Bevor wir uns um den Typfehler kümmern, benennen wir doch
  ;; partial-fact in improve um, Das wollen wir da ja reinstecken.

  (def f2 (
           (fn [improver] (improver improver))
           (fn [improver]
             (fn [n] (if (= 1 n) 1 (* n (improver (dec n))))))))

  (f2 1)
  (f2 2)

  ;; Und jetzt den Typfehler. Wir rufen (improver (dec n)) auf, aber
  ;; improver nimmt eigentlich eine Funktion als Parameter und liefert
  ;; eine Funktion, die eine Zahl nimmt.

  ;; Was passiert eigentlich, wenn wir den improver als Funtion nehmen,
  ;; also ((improver improver) (dec n))


  (def f2 (
           (fn [improver] (improver improver))
           (fn [improver]
             (fn [n] (if (= 1 n) 1 (* n ((improver improver) (dec n))))))))

  (f2 1)
  (f2 2)
  (f2 3)


  ;; Wenn wir ganz pedantisch sind dürfen wir kein def benutzen, aber
  ;; inlining überzeugt uns davon, das wir tatsächlich eine Lösung
  ;; haben

  (((fn [improver] (improver improver))
    (fn [improver]
      (fn [n] (if (= 1 n) 1 (* n ((improver improver) (dec n)))))))
   10)


  ;; Allerdings haben wir eine Komplexe Lösung, wir können die
  ;; Rekursion von der "Geschäftslogik" trennen:

  ( ;; Rekursionsbehandlung
   ((fn [r]
      ((fn [f] (f f))
       (fn [f]
         (r (fn [x] ((f f) x))))))
    ;; improve_fact
    (fn [partial_fact]
      (fn [n]
        (if (= 0 n) 1 (* n (partial_fact (dec n))))))

    ) 12)


  ;; Der Teil, der die Rekursion erledigt heisst Y Combinator
  (def Y (fn [r]
           ((fn [f] (f f))
            (fn [f]
              (r (fn [x] ((f f) x)))))))


  ((Y improve-fact) 11)

  ;; Der Y Kombinator erinnert an den Fixpunkt der beta Reduktion!

  (defn sum-seq [s]
    (if (empty? s)
      0
      (+ (first s) (sum-seq (rest s)))))

  (sum-seq [2 4 6])


  ;; Angenommen partial-sum-seq löst das Problem für Listen der Länge
  ;; n-1, dann löst (sum-seq-gen partial-sum-seq) das Problem für
  ;; Listen der Länge n.
  (defn sum-seq-gen [partial-sum-seq]
    (fn [s]
      (if (empty? s)
        0
        (+ (first s) (partial-sum-seq (rest s))))))

  ;; Das können wir also auch in den Y Combinator füttern.
  ((Y sum-seq-gen) [2 3 45])


  )