;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ; MDH modified 071112 (i.e., 12 November 2007)
; ; Extraction of realizers from the Dickson-2-2 proof, based on
; ; $Id: DicksonTwo.scm,v 1.3 2008/03/03 14:20:12 logik Exp $
; ; but using the Dialectica interpretation - no nc-quantifiers
; ; since not possible. Also extraction of upper bounds by 
; ; Monotone Dialectica which works somewhat faster 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(load "~/minlog/init.scm")
(set! COMMENT-FLAG #f)
(libload "nat.scm")

(add-var-name "f" "g" (py "nat=>nat"))
(add-var-name "i" "j" "l" (py "nat"))

; "DicksonTwo"
(set-goal (pf "all f,g excl i,j.i<j ! (f j<f i -> bot) ! (g j<g i -> bot)"))
(assume "f" "g")

(by-assume-minimal-wrt (pf "excl n T") "n" (pt "f") "MinH1" "H1")

; Generates two new goals: excl n T (trivial), and the existence of the
; minimal element (a hypothesis) implies our goal
(strip)
(use-with 1 (pt "0") "Truth-Axiom")
(drop "H1") 

; By the minimum principle, applied with
; excl n all m.n<m+1 -> f m<f n -> bot and measure function g,
; we obtain an element i that is a left-minimum of f and also minimal
; w.r.t. g

(by-assume-minimal-wrt
 (pf "excl n. all m.n<m+1 -> f m<f n -> bot") "i" (pt "g") "MinH2" "H2")
(exc-intro (pt "n"))
(assume "i")
(strip)
(use-with "MinH1" (pt "i") 4 "Truth-Axiom")

; By a third application of the minimum principle we choose the next
; left-minimum w.r.t. f

(by-assume-minimal-wrt (pf "excl l. i < l") "j" (pt "f") "MinH3" "H3")

(exc-intro (pt "i+1"))
(use "Truth-Axiom")

; Now we have i and j as desired
(exc-intro (pt "i") (pt "j"))
(use "H3")

(use-with "H2" (pt "j") "?")
(add-global-assumption "nat2" (pf "all n,m.n<m -> n<m+1"))
(use-with "nat2" (pt "i") (pt "j") "H3")

(strip)
(use-with "MinH2" (pt "j") 7 "?")

(strip)
(use-with "MinH3" (pt "m") 9 "?")
(add-global-assumption "nat1" (pf "all n,m,k.n<m -> m<k+1 -> n<k"))
(use-with "nat1" (pt "i") (pt "j") (pt "m") "H3" 8)
(define DickPrf (current-proof))
; ; ; NO NEED FOR preprocessing the proof, CONTRARY to A-translation
; ; ; (define dickson (np (expand-theorems (current-proof))))
; ; ; (define reduced-dickson (np (reduce-efq-and-stab dickson)))

(mload "../modules/diatup.scm")
(set! COMMENT-FLAG #t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  First we do an extraction of exact realizers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define vatmp (time (DIA-extract 'light DickPrf)))
(define FY-untup (tmpair-to-tuple (vatmpair-to-tmpair vatmp)))
(define FI-tmtup FY-untup)
(define FI-tmlst (tmtuple-to-tmlist FI-tmtup))
(length FI-tmlst)
(define ti (car FI-tmlst))
(define tj (cadr FI-tmlst))
(size-and-depth ti)
(size-and-depth tj)
; ; (string-length (term-to-string ti))
; ; (string-length (term-to-string tj))

(set! UNFOLDING-FLAG #t)
(define f (pt "[n][if (n < 4) (4 -- n) 0]"))
(define g (pt "[n][if (n=4) 1 0]"))
(define ri (time (nt (make-term-in-app-form
		     (make-term-in-app-form ti f) g))))
(pp ri)

; ;     4108 collections
; ;     65172 ms elapsed cpu time, including 874 ms collecting
; ;     65516 ms elapsed real time, including 889 ms collecting
; ;     4468278080 bytes allocated, including 4468896576 bytes reclaimed
; ; > 5

(define rj (time (nt (make-term-in-app-form
		     (make-term-in-app-form tj f) g))))
(pp rj)

; ;    4109 collections
; ;     65718 ms elapsed cpu time, including 1287 ms collecting
; ;     66219 ms elapsed real time, including 1284 ms collecting
; ;     4468308312 bytes allocated, including 4468935328 bytes reclaimed
; ; > 6

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Here we see a very small improvement when
;;; using Monotone Dialectica to extract upper bounds
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define vatmp (time (DIA-extract 'monot DickPrf)))
(define FY-untup (tmpair-to-tuple (vatmpair-to-tmpair vatmp)))
(define FI-tmtup FY-untup)
(define FI-tmlst (tmtuple-to-tmlist FI-tmtup))
(length FI-tmlst)
(define ti (car FI-tmlst))
(define tj (cadr FI-tmlst))
(size-and-depth ti)
(size-and-depth tj)
; ; (string-length (term-to-string ti))
; ; (string-length (term-to-string tj))

(set! UNFOLDING-FLAG #t)
(define f (pt "[n][if (n < 5) (5 -- n) 0]"))
(define g (pt "[n][if (n=5) 1 0]"))
(define ri (time (nt (make-term-in-app-form
		     (make-term-in-app-form ti f) g))))
(pp ri)
; ;     32 collections
; ;     500 ms elapsed cpu time, including 16 ms collecting
; ;     500 ms elapsed real time, including 15 ms collecting
; ;     35309680 bytes allocated, including 34870528 bytes reclaimed
; ; > 6

(define rj (time (nt (make-term-in-app-form
		     (make-term-in-app-form tj f) g))))
(pp rj)
; ;     97 collections
; ;     1484 ms elapsed cpu time, including 63 ms collecting
; ;     1500 ms elapsed real time, including 64 ms collecting
; ;     106025736 bytes allocated, including 105536088 bytes reclaimed
; ; > 7

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Here we use the same test-example as for A-translation
;;; and notice that it runs comparably fast, but gets just bounds
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define f (pt "[n][if (n=0) 4 [if (n=1) 3 n]]"))
(define g (pt "[n][if (n<3) 1  0]"))
(define ri (time (nt (make-term-in-app-form
		     (make-term-in-app-form ti f) g))))
(pp ri)
(define rj (time (nt (make-term-in-app-form
		     (make-term-in-app-form tj f) g))))
(pp rj)
