signature EXP =
sig

  fam exp    : type

  obj true   : exp
  obj false  : exp
  obj if     : exp -> exp -> exp -> exp

  obj z      : exp
  obj s      : exp
  obj pred   : exp

  obj zerop  : exp

  obj pair   : exp -> exp -> exp
  obj fst    : exp -> exp
  obj snd    : exp -> exp

  obj lam    : (exp -> exp) -> exp
  obj app    : exp -> exp -> exp

  obj let    : exp -> (exp -> exp) -> exp
  obj letrec : (exp -> exp) -> (exp -> exp) -> exp
  obj fix    : (exp -> exp) -> exp

end  % signature EXP

signature TP =
sig
  fam tp     : type

  obj bool   : tp
  obj nat    : tp
  obj cross  : tp -> tp -> tp
  obj arrow  : tp -> tp -> tp
end  % signature TP

signature OF (realizor Exp : EXP) (realizor Tp : TP) =
sig
  let
   include Exp Tp
  in
    fam of  : exp -> tp -> type.

    obj of_t       : of true bool.
    obj of_f       : of false bool.
    obj of_if      : of (if E1 E2 E3) A
                           <- of E1 bool 
                           <- of E2 A
                           <- of E3 A.

    obj of_z       : of z nat.
    obj of_s       : of s (arrow nat nat).
    obj of_pred    : of pred (arrow nat nat).

    obj of_zerop   : of zerop (arrow nat bool).

    obj of_pair    : of (pair E1 E2) (cross A1 A2) 
                           <- of E1 A1 
                           <- of E2 A2.
    obj of_fst     : of (fst E) A1 
                           <- of E (cross A1 A2).
    obj of_snd     : of (snd E) A2
                           <- of E (cross A1 A2).

    obj of_lam     : of (lam E) (arrow A1 A2)
                           <- {x:exp} of x A1 -> of (E x) A2.
    obj of_app     : of (app E1 E2) A1 <- of E1 (arrow A2 A1) <- of E2 A2.

    obj of_let     : of (let E1 E2) A2
                           <- of E1 A1
                           <- {x:exp} ({A:tp} of x A <- of E1 A)
                                         -> of (E2 x) A2.

    obj of_letrec  : of (letrec E1 E2) A2
                           <- of (fix E1) A1
                           <- {x:exp} ({A:tp} of x A <- of (fix E1) A)
                                         -> of (E2 x) A2.

    obj of_fix     : of (fix E) A <- {x:exp} of x A -> of (E x) A.
  end  % let include ...
end  % signature OF

signature VALUE (realizor Exp : EXP) =
sig
  let
   include Exp
  in
    fam value : exp -> type
    
    obj val_t        : value true
    obj val_f        : value false
    obj val_z        : value z
    obj val_s        : value s
    obj val_pred     : value pred
    obj val_zerop    : value zerop
    obj val_pair     : value V1 -> value V2 -> value (pair V1 V2)
    obj val_app_s    : value V -> value (app s V)
    obj val_lam      : value (lam E)
  end
end  % signature VALUE

signature NEVAL (realizor Exp : EXP) =
sig
  let
   include Exp
  in
    fam neval     : exp -> exp -> type

    obj neval_t          : neval true true
    obj neval_f          : neval false false
    obj neval_if_t       : neval (if E1 E2 E3) V2
                                <- neval E1 true 
                                <- neval E2 V2
    obj neval_if_f       : neval (if E1 E2 E3) V3
                                <- neval E1 false 
                                <- neval E3 V3

    obj neval_z          : neval z z
    obj neval_s          : neval s s
    obj neval_pred       : neval pred pred

    obj neval_zerop      : neval zerop zerop

    obj neval_pair       : neval (pair E1 E2) (pair V1 V2) 
                                <- neval E1 V1 
                                <- neval E2 V2
    obj neval_fst        : neval (fst E) V1
                                <- neval E (pair V1 V2)
    obj neval_snd        : neval (snd E) V2
                                <- neval E (pair V1 V2)

    obj neval_lam        : neval (lam E) (lam E)

    obj neval_app_lam    : neval (app E1 E2) V
                                <- neval E1 (lam E1') 
                                <- neval E2 V2 
                                <- neval (E1' V2) V
    obj neval_app_s      : neval (app E1 E2) (app s V) 
                                <- neval E1 s
                                <- neval E2 V
    obj neval_app_pred_s : neval (app E1 E2) V
                                <- neval E1 pred 
                                <- neval E2 (app s V)

    obj neval_app_zerop_t : neval (app E1 E2) true 
                                <- neval E1 zerop 
                                <- neval E2 z
    obj neval_app_zerop_f : neval (app E1 E2) false 
                                <- neval E1 zerop 
                                <- neval E2 (app s V)

    obj neval_let        : neval (let E1 E2) V2
                                <- neval E1 V1 
                                <- neval (E2 V1) V2
    obj neval_letrec     : neval (letrec E1 E2) V2
                                <- neval (fix E1) V1
                                <- neval (E2 V1) V2
    obj neval_fix        : neval (fix E) V <- neval (E (fix E)) V
  end
end  % signature NEVAL


"functor" VP
  (realizor Exp : EXP)
  (realizor Values : VALUES (realizor Exp = Exp))
  : NEVAL (realizor Exp = Exp) =
real
 let
   include Exp Values
  in
   %% fam neval : exp -> exp -> type
   %%           = [M:exp] [V:exp] value V
   %% or shorter:
   fam neval M V = value V

   %% neval_t : neval true true,
   %% val_t : value true,
   %% and  neval true true = value true.
   %% Thus we can define (interpret):
   obj neval_t = val_t
   obj neval_f = val_f

   %% neval_if_t : neval E2 V2 -> neval E1 true
   %%                 -> neval (if E1 E2 E3) V2,
   %% and  neval E2 V2 = neval (if E1 E2 E3) V2
   %%         = value V2.
   %% Thus we can define:
   %% obj neval_if_t = [P2 : value V2] [P1] P2
   obj neval_if_t P2 P1 = P2
   obj neval_if_f P3 P1 = P3

   obj neval_z = val_z
   obj neval_s = val_s
   obj neval_pred = val_pred
   obj neval_zerop = val_zerop

   obj neval_pair P2 P1 = val_pair P1 P2

   %% neval_fst : neval E (pair V1 V2) -> neval (fst E) V1,
   %% and  neval E (pair V1 V2) = value (pair V1 V2),
   %% but why does  P : value (pair V1 V2)
   %% imply that  P = val_pair P1 P2  ?
   %% Recall: we have to create  P1 : value V1  !
   %% In analogy to ML we write:

   obj neval_fst (val_pair P1 P2) = P1  % non-uniform
   obj neval_snd (val_pair P1 P2) = P2  % non-uniform

   obj neval_lam = val_lam

   obj neval_app_lam P3 P2 P1 = P3
   obj neval_app_s P2 P1 = val_app_s P2
   %% Another non-uniformity:
   obj neval_app_pred_s (val_app_s P0) P2 = P0  % !
   obj neval_app_zerop_t P2 P1 = val_t
   obj neval_app_zerop_f P2 P1 = val_f

   obj neval_let P2 P1 = P2
   obj neval_letrec P2 P1 = P1
   obj neval_fix P = P
  end
end  % "functor" VP

signature VPREL
  (realizor Exp : EXP)
  (realizor Values : VALUES (realizor Exp = Exp))
  (realizor NEval : NEVAL (realizor Exp = Exp)) =
sig
 let
   include Exp Values NEval
  in
   
    fam vp : neval E V -> value V -> type

    obj vp_t : vp (neval_t) (val_t)
    obj vp_f : vp (neval_f) (val_f)
    obj vp_if_t : vp (neval_if_t P2 P1) VP2 <- vp P2 VP2
    obj vp_if_f : vp (neval_if_f P3 P1) VP3 <- vp P3 VP3

    obj vp_z : vp (neval_z) (val_z)
    obj vp_s : vp (neval_s) (val_s)
    obj vp_pred : vp (neval_pred) (val_pred)

    obj vp_zerop : vp (neval_zerop) (val_zerop)

    obj vp_pair : vp (neval_pair P2 P1) (val_pair VP1 VP2)
                    <- vp P1 VP1
                    <- vp P2 VP2

    %% In order to show that vp defines a function,
    %% we need to know that vp !P ?VP will always
    %% instantiate ?VP == (val_pair ?VP1 ?VP2)
    %% when ?VP : value (pair V1 V2).

    obj vp_fst : vp (neval_fst P) VP1 <- vp P (val_pair VP1 VP2)
    obj vp_snd : vp (neval_snd P) VP2 <- vp P (val_pair VP1 VP2)

    obj vp_lam : vp (neval_lam) (val_lam)

    obj vp_app_lam : vp (neval_app_lam P3 P2 P1) VP3
                       <- vp P3 VP3
    obj vp_app_s : vp (neval_app_s P2 P1) (val_app_s VP2)
                     <- vp P2 VP2

    %% Again, here we need to know that ?VP == (val_app_s ?VP0) is the only
    %% possibility for  vp !P2 ?VP  to succeed
    obj vp_app_pred_s : vp (neval_app_pred_s P2 P1) VP0
                  <- vp P2 (val_app_s VP0)

    obj vp_app_zerop_t : vp (neval_app_zerop_t P2 P1) (val_t)
    obj vp_app_zerop_f : vp (neval_app_zerop_f P2 P1) (val_f)

    obj vp_let : vp (neval_let P2 P1) VP <- vp P2 VP
    obj vp_letrec : vp (neval_letrec P2 P1) VP <- vp P2 VP
    obj vp_fix : vp (neval_fix P) VP <- vp P VP

  end  % let include ...
end  % signature VPREL

signature SRREL
  (realizor Exp : EXP)
  (realizor Tp : TP)
  (realizor NEval : NEVAL (realizor Exp = Exp))
  (realizor Of : OF (realizor Exp = Exp) (realizor Tp = Tp)) =
sig
 let
   include Exp Tp NEval Of
  in
   %% sr (+P:neval E V) (+D:of E A) (-C:of V A)
   %%  produces a derivation  C : of V A
   %%  given an evaluation  P : neval E V
   %%  and a derivation  D : of E A
   fam sr : neval E V -> of E A -> of V A -> type.

   %% An auxiliary judgment to treat `let'.
   fam expd : ({x:exp} ({A:tp} of E1 A -> of x A) -> of (E2 x) A2)
               -> neval E1 V1
               -> of (E2 V1) A2
               -> type.

   obj sr_t : sr (neval_t) (of_t) (of_t).
   obj sr_f : sr (neval_f) (of_f) (of_f).
   obj sr_neval_if_t : sr (neval_if_t P2 P1) (of_if D3 D2 D1) C2
                          <- sr P2 D2 C2.
   obj sr_neval_if_f : sr (neval_if_f P3 P1) (of_if D3 D2 D1) C3
                          <- sr P3 D3 C3.

   obj sr_neval_z : sr (neval_z) (of_z) (of_z).
   obj sr_neval_s : sr (neval_s) (of_s) (of_s).
   obj sr_neval_pred : sr (neval_pred) (of_pred) (of_pred).

   obj sr_neval_zerop : sr (neval_zerop) (of_zerop) (of_zerop).

   obj sr_neval_pair : sr (neval_pair P2 P1) (of_pair D1 D2) (of_pair C1 C2)
                          <- sr P1 D1 C1
                          <- sr P2 D2 C2.

   obj sr_neval_fst : sr (neval_fst P) (of_fst D) C1
                         <- sr P D (of_pair C1 C2).
   obj sr_neval_snd : sr (neval_snd P) (of_snd D) C2
                         <- sr P D (of_pair C1 C2).

   obj sr_neval_lam : sr (neval_lam) (of_lam D) (of_lam D).

   obj sr_neval_app_lam :
          sr (neval_app_lam P3 P2 P1) (of_app D2 D1) C
                    <- sr P1 D1 (of_lam C1)
                    <- sr P2 D2 C2
                    <- sr P3 (C1 V2 C2) C.

   obj sr_neval_app_s :
          sr (neval_app_s P2 P1) (of_app D2 D1) (of_app C2 (of_s))
                   <- sr P1 D1 (of_s)
                   <- sr P2 D2 C2.

   obj sr_neval_app_pred_s :
          sr (neval_app_pred_s P2 P1) (of_app D2 D1) C2
                   <- sr P1 D1 (of_pred)
                   <- sr P2 D2 (of_app C2 (of_s)).

   obj sr_neval_app_zerop_t :
          sr (neval_app_zerop_t P2 P1) (of_app D2 D1) (of_t)
                   <- sr P1 D1 (of_zerop)
                   <- sr P2 D2 (of_z).

   obj sr_neval_app_zerop_f :
          sr (neval_app_zerop_f P2 P1) (of_app D2 D1) (of_f)
                   <- sr P1 D1 (of_zerop)
                   <- sr P2 D2 (of_app C2 (of_s)).

   obj sr_neval_let :
          sr (neval_let P2 P1) (of_let D2 D1) C
                   <- expd D2 P1 C2
                   <- sr P2 C2 C.

   %%% Cases for `letrec' and `fix' omitted for now.

   %%% Next the definition of `expd' for `let'

   obj expd_t : expd ([x:exp] [y:{A:tp} of E1 A -> of x A] of_t) P1 of_t. 

   %% Many other congruence cases omitted here.
   %% The critical case: we have reached
   %% the let-bound variable.

   obj expd_var :
          expd ([x:exp] [y:{A:tp} of E1 A -> of x A] y A1 D1) P1 C1
             <- sr P1 D1 C1.

  end  % let include ...
end  % signature SRREL
