-- LeroyCompilerVerificationCourse/Fixpoints.lean

import LeroyCompilerVerificationCourse.Imp

import LeroyCompilerVerificationCourse.Constprop

import Batteries.Data.List.Perm

@[grind] class OrderStruct (α : Sort u) where
  eq : α → α → Prop
  le : α → α → Prop
  beq : α → α → Bool
  le_trans : ∀ x y z, le x y -> le y z -> le x z
  beq_true' : ∀ x y : α, beq x y = true → eq x y := by admit /- proof elided -/

open OrderStruct

class Monotone (α : Sort u) (F : α → α) [OrderStruct α] where
  F_mon : ∀ {x y : α}, le x y → le (F x) (F y)

open Monotone

section FixpointExistence

variable (α : Sort u) (F : α → α) [OrderWithBot α]

open OrderStruct OrderWithBot

end FixpointExistence

section Iterate

variable (α : Sort u) [inst : OrderStruct α] (F : α → α) [Monotone α F]

open OrderStruct

@[grind] def iterate (x : α) (PRE : le x (F x)) (SMALL : ∀ z, le (F z) z -> le x z) : α :=
  if beq x (F x) then x else iterate (F x) (by admit /- proof elided -/
  ) (by admit /- proof elided -/
  )
  termination_by x
  decreasing_by
    grind [beq_false']

end Iterate

section Fixpoint

open OrderWithBot

variable {α : Sort u} [i : OrderWithBot α] (F : α → α) [Monotone α F]

end Fixpoint

section Constprop

open Std.HashMap

@[grind] def Eq' (S1 S2 : Store) : Prop := Equal S1 S2

def Eq'_sym : ∀ S1 S2, Eq' S1 S2 → Eq' S2 S1 :=

open OrderStruct

noncomputable instance : OrderStruct Store where
  eq := Equal
  le := Le
  beq (S1 S2 : Store) :=  Decidable.decide (Equal S1 S2)
  le_trans := Le_trans
  gt_wf := Gt_wf

end Constprop

section FixpointJoin

variable (Init : Store)

variable (F : Store → Store) [Monotone Store F]

instance : Monotone Store (fun x => Join Init (F x)) where
  F_mon := by admit /- proof elided -/

noncomputable def fixpoint_join : Store :=

-- Repository definitions used:
content: @[grind] def Join (S1 S2 : Store) : Store :=
  S1.filter (fun key _ => S2.get? key == S1.get? key)

content: def Store := Std.HashMap ident Int

content: @[grind] def Le (S1 S2 : Store) : Prop :=
  ∀ x n, S2.get? x = .some n -> S1.get? x = .some n

content: def Equal (S1 S2 : Store) := Std.HashMap.Equiv S1 S2

content: inductive com : Type where
  | SKIP                                        
  | ASSIGN (x : ident) (a : aexp)               
  | SEQ (c1 : com) (c2 : com)                   
  | IFTHENELSE (b : bexp) (c1 : com) (c2 : com) 
  | WHILE (b : bexp) (c1 : com)                 

content: @[grind] def Beval (S : Store) (b : bexp) : Option Bool :=
  match b with
  | .TRUE => .some true
  | .FALSE => .some false
  | .EQUAL a1 a2 => lift2 (fun m n => m == n) (Aeval S a1) (Aeval S a2)
  | .LESSEQUAL a1 a2 => lift2 (fun m n => m <= n) (Aeval S a1) (Aeval S a2)
  | .NOT b1 => lift1 (fun m => !m) (Beval S b1)
  | .AND b1 b2 => lift2 (fun m n => m && n) (Beval S b1) (Beval S b2)

content: @[grind] def lift1 {A B : Type} (f : A -> B) (o : Option A) : Option B :=
  match o with
  | .some x => .some (f x)
  | .none => .none

content: @[grind] def Aeval (S : Store) (a : aexp) : Option Int :=
  match a with
  | .CONST n => .some n
  | .VAR x => S.get? x
  | .PLUS a1 a2 => lift2 (Int.add) (Aeval S a1) (Aeval S a2)
  | .MINUS a1 a2 => lift2 (Int.sub) (Aeval S a1) (Aeval S a2)

content: @[grind] def lift2 {A B C : Type} (f : A -> B -> C) (o1 : Option A) (o2 : Option B) : Option C :=
  match o1, o2 with
  | .some x1, .some x2 => .some (f x1 x2) | _, _ => .none

content: inductive aexp : Type where
  | CONST (n : Int)               
  | VAR (x : ident)               
  | PLUS (a1 : aexp) (a2 : aexp)  
  | MINUS (a1 : aexp) (s2 : aexp) 

content: def ident := String deriving BEq, Repr, Hashable

content: inductive bexp : Type where
  | TRUE                              
  | FALSE                             
  | EQUAL (a1 : aexp) (a2 : aexp)     
  | LESSEQUAL (a1 : aexp) (a2 : aexp) 
  | NOT (b1 : bexp)                   
  | AND (b1 : bexp) (b2 : bexp)       

content: @[grind] def Update (x : ident) (N : Option Int) (S : Store) : Store :=
  match N with
  | .none => S.erase x
  | .some n => S.insert x n

content: notation:10 l:10 " ;; " r:11 => com.SEQ l r

-- Repository lemmas used:
content: theorem Equal_Le : ∀ S1 S2, Equal S1 S2 -> Le S1 S2

content: theorem Le_Join_l : ∀ S1 S2, Le S1 (Join S1 S2)

content: theorem  Le_Join_r : ∀ S1 S2, Le S2 (Join S1 S2)

-- Local definitions used:
content: @[grind] class OrderStruct (α : Sort u) where
  eq : α → α → Prop
  le : α → α → Prop
  beq : α → α → Bool
  le_trans : ∀ x y z, le x y -> le y z -> le x z
  beq_true' : ∀ x y : α, beq x y = true → eq x y := by admit /- proof elided -/

content: class Monotone (α : Sort u) (F : α → α) [OrderStruct α] where
  F_mon : ∀ {x y : α}, le x y → le (F x) (F y)

content: @[grind] def iterate (x : α) (PRE : le x (F x)) (SMALL : ∀ z, le (F z) z -> le x z) : α :=
  if beq x (F x) then x else iterate (F x) (by admit /- proof elided -/
  ) (by admit /- proof elided -/
  )
  termination_by x
  decreasing_by
    grind [beq_false']

content: @[grind] def Eq' (S1 S2 : Store) : Prop := Equal S1 S2

content: def Eq'_sym : ∀ S1 S2, Eq' S1 S2 → Eq' S2 S1 :=

content: noncomputable instance : OrderStruct Store where
  eq := Equal
  le := Le
  beq (S1 S2 : Store) :=  Decidable.decide (Equal S1 S2)
  le_trans := Le_trans
  gt_wf := Gt_wf

content: instance : Monotone Store (fun x => Join Init (F x)) where
  F_mon := by admit /- proof elided -/

content: noncomputable def fixpoint_join : Store :=

-- Local lemmas used:
content: @[grind] theorem iterate_correct (x : α) (PRE : le x (F x)) (SMALL : ∀ z, le (F z) z -> le x z) (heq : y = iterate _ F x PRE SMALL ) : eq y (F y) ∧ ∀ z, le (F z) z → le y z

content: @[grind] theorem Eq_Le : ∀ S1 S2, Eq' S1 S2 → Le S1 S2

content: @[grind] theorem Le_trans : ∀ S1 S2 S3, Le S1 S2 → Le S2 S3 → Le S1 S3

content: theorem fixpoint_join_eq : Eq' (Join Init (F (fixpoint_join Init F) )) (fixpoint_join Init F)

-- Target theorem and proof:
theorem fixpoint_join_sound : Le Init (fixpoint_join Init F) /\ Le (F (fixpoint_join Init F)) (fixpoint_join Init F)
:= by
  have LE : Le (Join Init (F (fixpoint_join Init F))) (fixpoint_join Init F) := by
    apply Eq_Le
    apply fixpoint_join_eq
  constructor
  · apply Le_trans
    rotate_left
    · exact LE
    · apply Le_Join_l
  · apply Le_trans
    rotate_left
    · exact LE
    · apply Le_Join_r