adamc@114: (* Copyright (c) 2008, Adam Chlipala
adamc@114:  * 
adamc@114:  * This work is licensed under a
adamc@114:  * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
adamc@114:  * Unported License.
adamc@114:  * The license text is available at:
adamc@114:  *   http://creativecommons.org/licenses/by-nc-nd/3.0/
adamc@114:  *)
adamc@114: 
adamc@114: (* Dependent list types presented in Chapter 8 *)
adamc@114: 
adamc@179: Require Import Arith List Tactics.
adamc@114: 
adamc@114: Set Implicit Arguments.
adamc@114: 
adamc@114: 
adamc@114: Section ilist.
adamc@123:   Variable A : Type.
adamc@114: 
adamc@123:   Fixpoint ilist (n : nat) : Type :=
adamc@114:     match n with
adamc@114:       | O => unit
adamc@114:       | S n' => A * ilist n'
adamc@114:     end%type.
adamc@114: 
adamc@149:   Definition inil : ilist O := tt.
adamc@149:   Definition icons n x (ls : ilist n) : ilist (S n) := (x, ls).
adamc@149: 
adamc@149:   Definition hd n (ls : ilist (S n)) : A := fst ls.
adamc@149:   Definition tl n (ls : ilist (S n)) : ilist n := snd ls.
adamc@149: 
adamc@149:   Implicit Arguments icons [n].
adamc@149: 
adamc@123:   Fixpoint index (n : nat) : Type :=
adamc@114:     match n with
adamc@114:       | O => Empty_set
adamc@114:       | S n' => option (index n')
adamc@114:     end.
adamc@114: 
adamc@114:   Fixpoint get (n : nat) : ilist n -> index n -> A :=
adamc@114:     match n return ilist n -> index n -> A with
adamc@114:       | O => fun _ idx => match idx with end
adamc@114:       | S n' => fun ls idx =>
adamc@114:         match idx with
adamc@114:           | None => fst ls
adamc@114:           | Some idx' => get n' (snd ls) idx'
adamc@114:         end
adamc@114:     end.
adamc@149: 
adamc@149:   Section everywhere.
adamc@149:     Variable x : A.
adamc@149: 
adamc@149:     Fixpoint everywhere (n : nat) : ilist n :=
adamc@149:       match n return ilist n with
adamc@149:         | O => inil
adamc@149:         | S n' => icons x (everywhere n')
adamc@149:       end.
adamc@149:   End everywhere.
adamc@149: 
adamc@149:   Section singleton.
adamc@149:     Variables x default : A.
adamc@149: 
adamc@149:     Fixpoint singleton (n m : nat) {struct n} : ilist n :=
adamc@149:       match n return ilist n with
adamc@149:         | O => inil
adamc@149:         | S n' =>
adamc@149:           match m with
adamc@149:             | O => icons x (everywhere default n')
adamc@149:             | S m' => icons default (singleton n' m')
adamc@149:           end
adamc@149:       end.
adamc@149:   End singleton.
adamc@149: 
adamc@149:   Section map2.
adamc@149:     Variable f : A -> A -> A.
adamc@149: 
adamc@149:     Fixpoint map2 (n : nat) : ilist n -> ilist n -> ilist n :=
adamc@149:       match n return ilist n -> ilist n -> ilist n with
adamc@149:         | O => fun _ _ => inil
adamc@149:         | S n' => fun ls1 ls2 => icons (f (hd ls1) (hd ls2)) (map2 _ (tl ls1) (tl ls2))
adamc@149:       end.
adamc@149:   End map2.
adamc@114: End ilist.
adamc@114: 
adamc@149: Implicit Arguments icons [A n].
adamc@114: Implicit Arguments get [A n].
adamc@149: Implicit Arguments map2 [A n].
adamc@114: 
adamc@114: Section hlist.
adamc@114:   Variable A : Type.
adamc@114:   Variable B : A -> Type.
adamc@114: 
adamc@114:   Fixpoint hlist (ls : list A) : Type :=
adamc@114:     match ls with
adamc@114:       | nil => unit
adamc@114:       | x :: ls' => B x * hlist ls'
adamc@114:     end%type.
adamc@114: 
adamc@125:   Definition hnil : hlist nil := tt.
adamc@125:   Definition hcons (x : A) (ls : list A) (v : B x) (hls : hlist ls) : hlist (x :: ls) :=
adamc@125:     (v, hls).
adamc@125: 
adamc@114:   Variable elm : A.
adamc@114: 
adamc@114:   Fixpoint member (ls : list A) : Type :=
adamc@114:     match ls with
adamc@114:       | nil => Empty_set
adamc@114:       | x :: ls' => (x = elm) + member ls'
adamc@114:     end%type.
adamc@114: 
adamc@126:   Definition hfirst (x : A) (ls : list A) (pf : x = elm) : member (x :: ls) :=
adamc@126:     inl _ pf.
adamc@126:   Definition hnext (x : A) (ls : list A) (m : member ls) : member (x :: ls) :=
adamc@126:     inr _ m.
adamc@126: 
adamc@114:   Fixpoint hget (ls : list A) : hlist ls -> member ls -> B elm :=
adamc@114:     match ls return hlist ls -> member ls -> B elm with
adamc@114:       | nil => fun _ idx => match idx with end
adamc@114:       | _ :: ls' => fun mls idx =>
adamc@114:         match idx with
adamc@114:           | inl pf => match pf with
adamc@114:                         | refl_equal => fst mls
adamc@114:                       end
adamc@114:           | inr idx' => hget ls' (snd mls) idx'
adamc@114:         end
adamc@114:     end.
adamc@125: 
adamc@125:   Fixpoint happ (ls1 ls2 : list A) {struct ls1} : hlist ls1 -> hlist ls2 -> hlist (ls1 ++ ls2) :=
adamc@125:     match ls1 return hlist ls1 -> hlist ls2 -> hlist (ls1 ++ ls2) with
adamc@125:       | nil => fun _ hls2 => hls2
adamc@125:       | _ :: _ => fun hls1 hls2 => (fst hls1, happ _ _ (snd hls1) hls2)
adamc@125:     end.
adamc@114: End hlist.
adamc@114: 
adamc@125: Implicit Arguments hnil [A B].
adamc@125: Implicit Arguments hcons [A B x ls].
adamc@114: Implicit Arguments hget [A B elm ls].
adamc@125: Implicit Arguments happ [A B ls1 ls2].
adamc@125: 
adamc@126: Implicit Arguments hfirst [A elm x ls].
adamc@126: Implicit Arguments hnext [A elm x ls].
adamc@126: 
adamc@125: Infix ":::" := hcons (right associativity, at level 60).
adamc@125: Infix "+++" := happ (right associativity, at level 60).
adamc@163: 
adamc@163: Section hmap.
adamc@163:   Variable A : Type.
adamc@163:   Variables B1 B2 : A -> Type.
adamc@163: 
adamc@163:   Variable f : forall x, B1 x -> B2 x.
adamc@163: 
adamc@163:   Fixpoint hmap (ls : list A) : hlist B1 ls -> hlist B2 ls :=
adamc@163:     match ls return hlist B1 ls -> hlist B2 ls with
adamc@163:       | nil => fun _ => hnil
adamc@163:       | _ :: _ => fun hl => f (fst hl) ::: hmap _ (snd hl)
adamc@163:     end.
adamc@179: 
adamc@179:   Implicit Arguments hmap [ls].
adamc@179: 
adamc@179:   Theorem hmap_happ : forall ls2 (h2 : hlist B1 ls2) ls1 (h1 : hlist B1 ls1),
adamc@179:     hmap h1 +++ hmap h2 = hmap (h1 +++ h2).
adamc@179:     induction ls1; crush.
adamc@179:   Qed.
adamc@163: End hmap.
adamc@163: 
adamc@163: Implicit Arguments hmap [A B1 B2 ls].