X-Git-Url: http://git.megacz.com/?p=coq-hetmet.git;a=blobdiff_plain;f=src%2FHaskFlattener.v;h=c42842a0d85e3ce12d68e0eec67554f0c6953475;hp=d805de4c7ab308c4c362225c75e0cd7d8536c885;hb=6a7c6977507488245ba4b8cabcf323920c25baef;hpb=a663de9a349ffe83a6c4fc10f1259f2fa6a915ed

diff --git a/src/HaskFlattener.v b/src/HaskFlattener.v
index d805de4..c42842a 100644
--- a/src/HaskFlattener.v
+++ b/src/HaskFlattener.v
@@ -831,11 +831,10 @@ Section HaskFlattener.
       | RAbsCo   Γ Δ Σ κ σ  σ₁ σ₂  lev => let case_RAbsCo := tt        in _
       | RApp     Γ Δ Σ₁ Σ₂ tx te lev   => let case_RApp := tt          in _
       | RLet     Γ Δ Σ₁ Σ₂ σ₁ σ₂ lev   => let case_RLet := tt          in _
-      | RCut    Γ Δ Σ₁ Σ₁₂ Σ₂ Σ₃ l    => let case_RCut := tt          in _
-      | RLeft   Γ Δ Σ₁ Σ₂  Σ     l    => let case_RLeft := tt in _
-      | RRight  Γ Δ Σ₁ Σ₂  Σ     l    => let case_RRight := tt in _
+      | RCut     Γ Δ Σ Σ₁ Σ₁₂ Σ₂ Σ₃ l  => let case_RCut := tt          in _
+      | RLeft    Γ Δ Σ₁ Σ₂  Σ     l    => let case_RLeft := tt in _
+      | RRight   Γ Δ Σ₁ Σ₂  Σ     l    => let case_RRight := tt in _
       | RWhere   Γ Δ Σ₁ Σ₂ Σ₃ σ₁ σ₂ lev   => let case_RWhere := tt          in _
-      | RJoin    Γ p lri m x q l       => let case_RJoin := tt in _
       | RVoid    _ _       l           => let case_RVoid := tt   in _
       | RBrak    Γ Δ t ec succ lev           => let case_RBrak := tt         in _
       | REsc     Γ Δ t ec succ lev           => let case_REsc := tt          in _
@@ -931,12 +930,6 @@ Section HaskFlattener.
       apply flatten_coercion; auto.
       apply (Prelude_error "RCast at level >0; casting inside of code brackets is currently not supported").
 
-    destruct case_RJoin.
-      simpl.
-      destruct l;
-        [ apply nd_rule; apply RJoin | idtac ];
-        apply (Prelude_error "RJoin at depth >0").
-
     destruct case_RApp.
       simpl.
 
@@ -1029,41 +1022,46 @@ Section HaskFlattener.
         rewrite <- IHΣ₁₂1.
         rewrite <- IHΣ₁₂2.
         reflexivity.
-      simpl.
-      repeat drop_simplify.
-      simpl.
-      repeat take_simplify.
+      simpl; repeat drop_simplify.
+      simpl; repeat take_simplify.
       simpl.
       set (drop_lev (ec :: lev) (Σ₁₂ @@@ (ec :: lev))) as x1.
       rewrite take_lemma'.
       rewrite mapOptionTree_compose.
       rewrite mapOptionTree_compose.
       rewrite mapOptionTree_compose.
+      rewrite mapOptionTree_compose.
       rewrite unlev_relev.
       rewrite <- mapOptionTree_compose.
       rewrite <- mapOptionTree_compose.
+      rewrite <- mapOptionTree_compose.
       eapply nd_comp; [ idtac | eapply nd_rule; eapply RCut ]. 
       apply nd_prod.
       apply nd_id.
       eapply nd_comp.
       eapply nd_rule.
       eapply RArrange.
+      eapply ALeft.
       eapply ARight.
       unfold x1.
       rewrite drop_to_nothing.
       apply arrangeCancelEmptyTree with (q:=(mapTree (fun _ : ??(HaskType Γ ★) => tt) Σ₁₂)).
       admit. (* OK *)
-      eapply nd_comp; [ eapply nd_rule; eapply RArrange; eapply ACanL | idtac ].
+      eapply nd_comp; [ eapply nd_rule; eapply RArrange; eapply ALeft; eapply ACanL | idtac ].
       set (mapOptionTree flatten_type Σ₁₂) as a.
       set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) Σ₁)) as b.
       set (mapOptionTree flatten_leveled_type (drop_lev (ec :: lev) Σ₂)) as c.
       set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) Σ₂)) as d.
+      set (mapOptionTree flatten_leveled_type (drop_lev (ec :: lev) Σ)) as e.
+      set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) Σ)) as f.
       eapply nd_comp; [ idtac | eapply nd_rule; eapply RCut ].
       eapply nd_comp; [ apply nd_llecnac | idtac ].
       apply nd_prod.
       simpl.
-      eapply ga_first.
-      eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AExch ].
+      eapply secondify.
+      apply ga_first.
+      eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ALeft; eapply AExch ].
+      eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuAssoc ].
       simpl.
       apply precompose.