### some solutions for TD5

parent 445c32ce
solutions/td5.v 0 → 100644
 (* TD5 *) Require Import Arith List Bool NArith. Import ListNotations. Set Implicit Arguments. (* Exercise 1 : Exercise 2 of TD4, this time with dependent types expressing that trees are necessarily perfect *) Module BList_DepType. (* See seance5-english.v for explanations *) Inductive fulltree (A:Type) : nat -> Type := | FLeaf : A -> fulltree A 0 | FNode n : fulltree A n -> fulltree A n -> fulltree A (S n). Arguments FLeaf {A}. Arguments FNode {A} {n}. Definition blist (A:Type) := list { n & fulltree A n }. Definition empty_blist {A} : blist A := []. Definition size1_blist {A} (a:A) : blist A := [existT _ _ (FLeaf a)]. Definition size2_blist {A} (a b:A) : blist A := [existT _ _ (FNode (FLeaf a) (FLeaf b))]. (* A comparison returning (dis)equality proofs in addition to the yes/no answer *) Check Nat.eq_dec. (* For instance : match Nat.eq_dec n m with | left p => (* here (p : n=m) *) ... | right _ => (* here n <> m *) ... end *) (* Just like Vcast (see seance 4) *) Definition treecast {A} {n} {m} (v: fulltree A n)(h : n = m) : fulltree A m := match h with | eq_refl => v end. (* Important auxiliary function : putting a tree on the left of a bl. *) (* invariant : depth t <= depth of leftmost tree in the bl *) Fixpoint constree {A} {n:nat} (t:fulltree A n) (bl:blist A) : blist A := match bl with | [] => [existT _ n t] | (existT _ m t')::bl' => match Nat.eq_dec n m with | left p => constree (FNode (treecast t p) t') bl' | right _ => (existT _ n t) :: bl end end. Definition cons {A} (a:A) bl := constree (FLeaf a) bl. Compute cons 2 (cons 3 (size2_blist 5 7)). (* Unlike with Vcast in seance 4, this computes ok since Nat.eq_dec returns a proof that isn't opaque... *) (* digression : from regular list to blist and back *) Fixpoint list_to_blist {A} (l:list A) : blist A := match l with | [] => empty_blist | x::l => cons x (list_to_blist l) end. Compute list_to_blist [1;2;3;4;5;6;7]. Fixpoint tree_to_list {A} {n} (t:fulltree A n) : list A := match t with | FLeaf a => [a] | FNode t t' => tree_to_list t ++ tree_to_list t' end. Fixpoint blist_to_list {A} (bl:blist A) := match bl with | [] => [] | (existT _ _ t)::bl => tree_to_list t ++ blist_to_list bl end. (* end of digression *) (* depth t < depth of every tree in acc *) Fixpoint unconstree {A} {n} (t:fulltree A n) (acc : blist A) : A * blist A := match t with | FLeaf a => (a, acc) | FNode t t' => unconstree t ((existT _ _ t')::acc) end. Definition uncons {A} (bl : blist A) : option (A * blist A) := match bl with | [] => None | (existT _ _ t)::bl => Some (unconstree t bl) end. (* O(lg(n)) *) (* invariant : n < size t (which is 2^depth t) *) Fixpoint nthtree {A} {d} (t:fulltree A d) n : option A := match t with | FLeaf a => Some a (* normally here n must be 0 *) | FNode t1 t2 => let size_t1 := 2^(pred d) in if n None | (existT _ d t)::bl' => let size_t := 2^d in if n tree A | node : tree A -> tree A -> tree A. Definition option_bind {A B} (o : option A) (f:A -> option B) : option B := match o with | Some x => f x | None => None end. Infix ">>=" := option_bind (at level 20, left associativity). Fixpoint perfect_depth {A} (t:tree A) : option nat := match t with | leaf _ => Some 0 | node g d => perfect_depth g >>= fun dg => perfect_depth d >>= fun dd => if dg =? dd then Some (S dg) else None end. (* Exercise 3 *) (* first attempt, with List.flat_map, and hence no elimination of redundant results. *) Definition listbind {A B} (l:list A) (f:A->list B) := List.flat_map f l. Print flat_map. Infix ">>=" := listbind (at level 20, left associativity). Definition next_score n := [n+3;n+5;n+7]. Fixpoint next_scores k l := match k with | O => l | S k' => next_scores k' l >>= next_score end. Compute next_scores 5 . (* Looots of redundancies *) (* Compute next_scores 10  (* Stack overflow during display... *) *) Compute let l := next_scores 10  in N.of_nat (length l). (* 59049 elements ! *) (* Better, without redundancies (but just for list nat) *) Fixpoint listmerge l1 l2 (* for strictly sorted lists of numbers *) := match l1 with | [] => l2 | x1::l1' => (fix listmerge_l1 l2 := match l2 with | [] => l1 | x2::l2' => match Nat.compare x1 x2 with | Lt => x1 :: listmerge l1' l2 | Eq => x1 :: listmerge l1' l2' | Gt => x2 :: listmerge_l1 l2' end end) l2 end. Compute listmerge [1;2;4] [2;3;5]. (* Same as flat_map, but here all lists are supposed to be strictly sorted, and we merge them instead of ++ *) Fixpoint listbind2 (l:list nat) (f:nat->list nat) := match l with | [] => [] | a :: l' => listmerge (f a) (listbind2 l' f) end. Infix ">>=" := listbind2 (at level 20, left associativity). Fixpoint next_scores_v2 k l := match k with | O => l | S k' => next_scores_v2 k' l >>= next_score end. Compute next_scores_v2 10 . (* [30; 32; 34; 36; 38; 40; 42; 44; 46; 48; 50; 52; 54; 56; 58; 60; 62; 64; 66; 68; 70] *) Compute length (next_scores_v2 10 ). (* 21 unique answers instead of 59049 ! *) (* End of 3.1 : what about scoring at most 10 times ? We just keep the current score a in addition to [next_score a] *) Fixpoint next_scores_large k l := match k with | O => l | S k' => next_scores_large k' l >>= fun a => a :: next_score a end. Compute next_scores_large 10 . (* [0; 3; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 28; 29; 30; 31; 32; 33; 34; 35; 36; 37; 38; 39; 40; 41; 42; 43; 44; 45; 46; 47; 48; 49; 50; 51; 52; 53; 54; 55; 56; 57; 58; 59; 60; 61; 62; 63; 64; 66; 68; 70] *) (* Exercise 3.2 *) (* Back to unsorted list bind (since listbind2 was only for list nat) *) Infix ">>=" := listbind (at level 20, left associativity). Compute List.seq 1 100. (* 1 to 100 *) (* A first naive attemp, generating all combinations for a,b and c *) Definition pytha n := let nums := List.seq 1 n in nums >>= fun a => nums >>= fun b => nums >>= fun c => if a*a+b*b =? c*c then [(a,b,c)] else []. (* Quite slow... *) Time Compute pytha 40. (* 4 sec, then 11s here for 50, then +∞ for 100 *) (* Three possible improvements : - Deduce c from a and b, thanks to Nat.sqrt (but be careful to check whether c is <= n in this case) - Consider only b for which a>= fun a => (List.seq (a+1) (n-a)) >>= fun b => let c := Nat.sqrt (a*a+b*b) in if (c <=? n) && (a*a+b*b =? c*c) then [(a,b,c)] else []. Compute pytha_opt 100. (* 3s, even with nat *) Fixpoint seqN a n := match n with | 0 => [] | S n => a :: (seqN (N.succ a) n) end. Definition pythaN n := (seqN 1%N n) >>= fun a => (seqN (a+1)%N (n-N.to_nat a)) >>= fun b => let (c,rem) := N.sqrtrem (a*a+b*b) in if (rem =? 0)%N && (c <=? N.of_nat n)%N then [(a,b,c)] else []. Compute pythaN 100. (* 0s *) (** Exercise 3.3 *) Definition closeby n m := (n =? S m) || (S n =? m). (* A not-so-nice solution. Any better proposal ? *) Definition L_R_B_P := let positions := [1;2;3;4] in positions >>= fun L => positions >>= fun R => if negb (closeby L R) then [] else positions >>= fun B => if (B =? R) || (B =? L) then [] else positions >>= fun P => if (closeby P L) && (negb (P =?R)) && (negb (P =? B)) then [(L,R,B,P)] else []. Compute L_R_B_P. (* 4 solutions *)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment