diff --git a/ProofWidgets/Demos/Graph.lean b/ProofWidgets/Demos/Graph/Basic.lean similarity index 100% rename from ProofWidgets/Demos/Graph.lean rename to ProofWidgets/Demos/Graph/Basic.lean diff --git a/ProofWidgets/Demos/ExprGraph.lean b/ProofWidgets/Demos/Graph/ExprGraph.lean similarity index 100% rename from ProofWidgets/Demos/ExprGraph.lean rename to ProofWidgets/Demos/Graph/ExprGraph.lean diff --git a/ProofWidgets/Demos/Graph/MVarGraph.lean b/ProofWidgets/Demos/Graph/MVarGraph.lean new file mode 100644 index 0000000..3630086 --- /dev/null +++ b/ProofWidgets/Demos/Graph/MVarGraph.lean @@ -0,0 +1,217 @@ +import ProofWidgets.Component.GraphDisplay +import ProofWidgets.Component.Panel.Basic +import ProofWidgets.Component.OfRpcMethod + +/-! This demo visualizes the graph of metavariable assignments in tactic proofs. -/ + +universe u v + +open Lean Meta + +/-- Adjacency list representation of a directed graph with labelled edges. -/ +abbrev Graph (α β : Type u) [BEq α] [Hashable α] := Std.HashMap α (List (α × β)) + +variable {α β : Type u} [BEq α] [Hashable α] + +/-- Filter out vertices not reachable from a vertex in `vs`. -/ +def Graph.filterReachable (g : Graph α β) (vs : List α) : Graph α β := Id.run do + let mut work := vs + let mut reached := Std.HashSet.ofList vs + -- FIXME: `do` notation freaks out if `a` and `β` live in different universes + while h : !work.isEmpty do + let v := work.head (by simpa using h) + work := work.tail + for (u, _) in g.get? v |>.getD [] do + if !reached.contains u then + work := u :: work + reached := reached.insert u + return g.filter fun v _ => reached.contains v + +/-- Return the user name if it exists, otherwise the prettified underlying name. -/ +def _root_.Lean.MVarId.getName (m : MVarId) : MetaM Name := do + let d ← m.getDecl + if !d.userName.isAnonymous then + return d.userName + let .num _ n := m.name | return m.name + return Name.anonymous.str "m" |>.num n + +/-- Return the graph of metavariables, +where a `true` edge `m → n` exists iff `n` is assigned an expression that uses `m`, +and a `false` edge `m → n` exists iff the type of `n` depends on `m`. -/ +def buildMVarGraph : MetaM (Graph MVarId Bool) := do + let mut g : Graph MVarId Bool := {} + for (m, _) in (← getMCtx).decls do + g := g.alter m (·.getD []) + if let some e := (← getMCtx).eAssignment.find? m then + for n in (e.collectMVars {}).result do + g := g.alter n ((m, true) :: ·.getD []) + if let some a := (← getMCtx).dAssignment.find? m then + let n := a.mvarIdPending + g := g.alter n ((m, true) :: ·.getD []) + for n in ((← m.getType).collectMVars {}).result do + g := g.alter n ((m, false) :: ·.getD []) + return g + +open ProofWidgets Jsx in +def mkLabel (e : MVarId) + (stroke := "var(--vscode-editor-foreground)") + (fill := "var(--vscode-editor-background)") : + MetaM (Nat × Nat × Html) := do + let fmt := s!"?{← e.getName}" + let fmtTp ← withOptions (·.setNat `pp.deepTerms.threshold 2) + (toString <$> ppExpr (← e.getType')) + let len := fmt.length + fmtTp.length + 3 + let w := min (15 + len * 6) 100 + let h := max 20 (20 * (1 + len / 15)) + let x : Int := -w/2 + let y : Int := -h/2 + return (w, h, + + + {.text fmt} : {.text fmtTp} + + + ) + +open ProofWidgets Jsx in +def drawMVarGraph (goals : List MVarId) : MetaM Html := do + let mvars ← buildMVarGraph + let mg := goals.head! + let g := mvars.filterReachable goals + + let mut vertices := #[] + let mut edges := #[] + let mut maxLabelRadius := 0.0 + for (m, ns) in g do + -- TODO: mark delayed assigned mvars in yet another colour? + let vAssigned ← m.isAssignedOrDelayedAssigned + let (w, h, label) ← mkLabel m + (stroke := + if m == mg then "var(--vscode-lean4-infoView\\.turnstile)" + else if vAssigned then "var(--vscode-editor-foreground)" + else "var(--vscode-lean4-infoView\\.caseLabel)") + (fill := + if vAssigned then "var(--vscode-editorHoverWidget-background)" + else "var(--vscode-editor-background)") + maxLabelRadius := max maxLabelRadius (Float.sqrt <| (w.toFloat/2)^2 + (h.toFloat/2)^2) + let val? ← (← getMCtx).eAssignment.find? m |>.mapM fun v => + return + {.text s!"?{← m.getName}"} := + + + let delayedVal? ← (← getMCtx).dAssignment.find? m |>.mapM fun n => + return + {.text s!"?{← m.getName}"} [delayed] := + {.text s!"?{← n.mvarIdPending.getName}"} + + vertices := vertices.push { + id := toString m.name + label + boundingShape := .rect w.toFloat h.toFloat + details? := val? <|> delayedVal? + } + for (n, b) in ns do + if b then + edges := edges.push { + source := toString m.name + target := toString n.name + } + else + edges := edges.push { + source := toString m.name + target := toString n.name + attrs := #[("strokeDasharray", "5,5")] + } + return + +open Server ProofWidgets Jsx + +@[server_rpc_method] +def MVarGraph.rpc (props : PanelWidgetProps) : RequestM (RequestTask Html) := + RequestM.asTask do + let inner : Html ← (do + -- Are there any goals unsolved? If so, the first one is the current main goal. + if props.goals.isEmpty then + return No goals. + let some g := props.goals[0]? | unreachable! + + -- Execute the next part using the metavariable context and local context of the main goal. + g.ctx.val.runMetaM {} do + let md ← g.mvarId.getDecl + let lctx := md.lctx |>.sanitizeNames.run' {options := (← getOptions)} + Meta.withLCtx lctx md.localInstances do + drawMVarGraph <| props.goals.toList.map (·.mvarId)) + + return
+ Metavariable graph +
{inner}
+
+ +@[widget_module] +def MVarGraph : Component ProofWidgets.PanelWidgetProps := + mk_rpc_widget% MVarGraph.rpc + +show_panel_widgets [local MVarGraph] + +-- When printing an assigned metavariable `?m := v`, +-- print out the metavariable name `?m` rather than `v`. +set_option pp.instantiateMVars false +-- Do the same for delayed assigned metavariables. +set_option pp.mvars.delayed true + +example {P Q : Prop} (p : P) (q : Q) : P ∧ Q := by + constructor + . exact p + . exact q + +example {P Q R : Prop} (p : P) (q : Q) (r : R) : (P ∧ Q) ∧ R := by + constructor + constructor + . exact p + . exact q + . exact r + +example {P Q R : Prop} (pq : P → Q) (qr : Q → R) : P → R := by + intro p + apply qr + apply pq + exact p + +example {α : Type} {P Q : α → Prop} (pq : ∀ x, P x → Q x) + (px : ∀ x, P x) : ∀ x, Q x := by + intro y + apply pq + apply px + +example {α : Type} {P : α → Prop} {a : α} (pa : P a) : + ∃ x, P x := by + refine ⟨?w, ?h⟩ + exact a + exact pa + +example {α : Type} {P : α → Prop} {a b c : α} + (ab : a = b) (bc : b = c) (pa : P a) : P c := by + rw [← bc] + rw [← ab] + exact pa + +example (n : Nat) : n = 0 ∨ ∃ m, n = m + 1 := by + induction n -- a big mess + . exact Or.inl rfl + . exact Or.inr ⟨_, rfl⟩