├── .gitignore ├── scripts ├── cabal.patch ├── sedscript ├── core.patch ├── operations.patch └── properties.patch ├── src ├── discarded.txt ├── Aux.v ├── Extraction.v ├── properties.txt ├── StackSetHeader.hs ├── ListLemmas.v ├── StackSet.v └── Properties.v ├── README.md ├── LICENSE └── Makefile /.gitignore: -------------------------------------------------------------------------------- 1 | build/* 2 | *.glob 3 | *.vo 4 | *.#* 5 | .DS_Store -------------------------------------------------------------------------------- /scripts/cabal.patch: -------------------------------------------------------------------------------- 1 | 88d87 2 | < ghc-options: -Werror 3 | -------------------------------------------------------------------------------- /scripts/sedscript: -------------------------------------------------------------------------------- 1 | 1,4d 2 | s/delete :: /delete :: Ord a3 => /g 3 | s/remove0 :: /remove0 :: Ord a1 => /g 4 | s/insert :: /insert :: Ord a1 => /g 5 | s/sink :: /sink :: Ord a3 => /g 6 | s/float ::/float :: Ord a3=> /g -------------------------------------------------------------------------------- /scripts/core.patch: -------------------------------------------------------------------------------- 1 | 21c21 2 | < ScreenId(..), ScreenDetail(..), XState(..), 3 | --- 4 | > ScreenDetail(..), XState(..), 5 | 114c114 6 | < type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail 7 | --- 8 | > type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenDetail 9 | 120,122d119 10 | < -- | Physical screen indices 11 | < newtype ScreenId = S Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real) 12 | < 13 | 14 | -------------------------------------------------------------------------------- /scripts/operations.patch: -------------------------------------------------------------------------------- 1 | 130,131c130,131 2 | < >>= W.filter (`M.notMember` W.floating ws) 3 | < >>= W.filter (`notElem` vis) 4 | --- 5 | > >>= W.filterStack (`M.notMember` W.floating ws) 6 | > >>= W.filterStack (`notElem` vis) 7 | 374c374 8 | < screenWorkspace :: ScreenId -> X (Maybe WorkspaceId) 9 | --- 10 | > screenWorkspace :: W.ScreenId -> X (Maybe WorkspaceId) 11 | 426c426 12 | < floatLocation :: Window -> X (ScreenId, W.RationalRect) 13 | --- 14 | > floatLocation :: Window -> X (W.ScreenId, W.RationalRect) 15 | 444c444 16 | < -> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)) 17 | --- 18 | > -> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenDetail)) 19 | -------------------------------------------------------------------------------- /src/discarded.txt: -------------------------------------------------------------------------------- 1 | -- Not about stacksets but about Xmonad.Layout 2 | ,("tile 1 window fullsize", mytest prop_tile_fullscreen) 3 | ,("tiles never overlap", mytest prop_tile_non_overlap) 4 | ,("split hozizontally", mytest prop_split_hoziontal) 5 | ,("split verticalBy", mytest prop_splitVertically) 6 | ,("pure layout tall", mytest prop_purelayout_tall) 7 | ,("send shrink tall", mytest prop_shrink_tall) 8 | ,("send expand tall", mytest prop_expand_tall) 9 | ,("send incmaster tall", mytest prop_incmaster_tall) 10 | ,("pure layout full", mytest prop_purelayout_full) 11 | ,("send message full", mytest prop_sendmsg_full) 12 | ,("describe full", mytest prop_desc_full) 13 | ,("describe mirror", mytest prop_desc_mirror) 14 | -- about Xmonad.Operations 15 | ,("window hints: inc", mytest prop_resize_inc) 16 | ,("window hints: inc all", mytest prop_resize_inc_extra) 17 | ,("window hints: max", mytest prop_resize_max) 18 | ,("window hints: max all ", mytest prop_resize_max_extra) 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | This repository contains an implementation of xmonad's StackSet module 3 | in Coq. Extracting Haskell from this Coq file produces a drop-in 4 | replacement module for the original Haskell module (once it has been 5 | massaged a bit by a few innocuous shell scripts). 6 | 7 | The Makefile has mostly been generated by coq_makefile. It contains 8 | several build targets: 9 | 10 | - make patched_xmonad -- downloads xmonad and applies several 11 | reasonably innocent patches to the xmonad source; 12 | 13 | - make extraction -- extract Haskell code from the Coq 14 | implementation of the StackSet module, and postprocess it with 15 | some final shell scripts; 16 | 17 | - make integration -- tries to build the patched xmonad with the 18 | extracted StackSet module; 19 | 20 | - make quickcheck -- also runs the QuickCheck testsuite on the 21 | resulting xmonad binary; 22 | 23 | - make theorems -- gives some indication of how many QuickCheck 24 | properties have been formalized. 25 | 26 | The Coq code is in the src/ directory. Most of the Coq code is in the 27 | StackSet.v module. The Extraction.v module has various extraction 28 | commands to generate somewhat palatable Haskell code. Several 29 | QuickCheck properties have alread been proven in the Properties.v file. 30 | 31 | The necessary shell scripts and patches are all in the scripts/directory. 32 | -------------------------------------------------------------------------------- /scripts/properties.patch: -------------------------------------------------------------------------------- 1 | 4c4 2 | < import XMonad.StackSet hiding (filter) 3 | --- 4 | > import XMonad.StackSet 5 | 8d7 6 | < import qualified XMonad.StackSet as S (filter) 7 | 42,43c41,42 8 | < instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary l, Arbitrary sd) 9 | < => Arbitrary (StackSet i l a s sd) where 10 | --- 11 | > instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary l, Arbitrary s) 12 | > => Arbitrary (StackSet i l a s) where 13 | 70c69 14 | < fromList :: (Integral i, Integral s, Eq a) => (i, [sd], [Maybe Int], [[a]], l) -> StackSet i l a s sd 15 | --- 16 | > fromList :: (Integral i, Integral s, Eq a) => (i, [s], [Maybe Int], [[a]], l) -> StackSet i l a s 17 | 87c86 18 | < type T = StackSet (NonNegative Int) Int Char Int Int 19 | --- 20 | > type T = StackSet (NonNegative Int) Int Char Int 21 | 477c476 22 | < Just s@(Stack i _ _) -> integrate' (S.filter (/= i) s) == filter (/= i) (integrate' (Just s)) 23 | --- 24 | > Just s@(Stack _ i _) -> integrate' (filterStack (/= i) s) == filter (/= i) (integrate' (Just s)) 25 | 594c593 26 | < else (differentiate xs) == Just (Stack (head xs) [] (tail xs)) 27 | --- 28 | > else (differentiate xs) == Just (Stack [] (head xs) (tail xs)) 29 | 979c978 30 | < ,("new fails with abort", mytest prop_new_abort) 31 | --- 32 | > -- ,("new fails with abort", mytest prop_new_abort) 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2007,2008 Spencer Janssen 2 | Copyright (c) 2007,2008 Don Stewart 3 | Copyright (c) 2010, Wouter Swierstra 4 | 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | 2. Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | 3. Neither the name of the author nor the names of his contributors 19 | may be used to endorse or promote products derived from this software 20 | without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 23 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 26 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 27 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 28 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 29 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 30 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /src/Aux.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | 3 | Set Implicit Arguments. 4 | 5 | Fixpoint splitAt (a : Set) (k : nat) (xs : list a) 6 | : (list a * list a) := 7 | match (k,xs) with 8 | | (O, xs) => (nil, xs) 9 | | (S m, nil) => (nil, nil) 10 | | (S m, y :: ys) => (y :: fst (splitAt m ys), snd (splitAt m ys)) 11 | end. 12 | 13 | Fixpoint zipWith3 14 | (a b c d : Set) 15 | (f : a -> b -> c -> d) 16 | (seens : list a) 17 | (sids : list b) 18 | (sds : list c) 19 | : list d 20 | := match (seens, sids, sds) with 21 | | (s :: seenTail, sid :: sidTail, sd :: sdTail) => 22 | f s sid sd :: zipWith3 f seenTail sidTail sdTail 23 | | _ => nil 24 | end. 25 | 26 | Definition maybe : forall a b, b -> (a -> b) -> option a -> b := 27 | fun a b dflt f opt => match opt with 28 | | None => dflt 29 | | Some x => f x 30 | end. 31 | 32 | Definition option_bind {a b : Set} : 33 | option a -> (a -> option b) -> option b := fun c f => 34 | match c with 35 | | None => None 36 | | Some x => f x 37 | end. 38 | 39 | Infix ">>=" := option_bind (at level 80, right associativity). 40 | 41 | Fixpoint removeList (a : Set) (eqa : forall (x y : a), {x = y} + {x <> y}) (xs ys : list a) : list a := 42 | match ys with 43 | | nil => xs 44 | | (z :: zs) => remove eqa z (removeList eqa xs zs) 45 | end. 46 | 47 | Fixpoint iterate (a : Set) (n : nat) (f : a -> a) (x : a) : a := 48 | match n with 49 | | O => x 50 | | S k => iterate k f (f x) 51 | end. 52 | 53 | Fixpoint deleteBy (a : Set) (p : a -> a -> bool) (x : a) (xs : list a) : list a 54 | := match xs with 55 | | nil => nil 56 | | y :: ys => if p x y then ys else y :: deleteBy p x ys 57 | end. 58 | 59 | Fixpoint applyN (a : Set) (n : nat) (x : a) (f : a -> a) : a := 60 | match n with 61 | | 0 => x 62 | | S k => applyN k (f x) f 63 | end. 64 | 65 | Fixpoint elemIndex (a : Set) (eqa : forall (x y : a), {x = y} + {x <> y}) (y : a) (xs : list a) : option nat 66 | := match xs with 67 | | nil => None 68 | | x :: xs => match eqa x y with 69 | | left _ => Some 0 70 | | right _ => elemIndex eqa y xs >>= fun n => Some (S n) 71 | end 72 | end. 73 | 74 | Lemma appendNonNil (a : Set) (x : a) (xs ys : list a) : 75 | ys ++ (x :: xs) <> nil. 76 | induction ys; discriminate. 77 | Qed. 78 | 79 | Lemma revNil (A : Set) (xs : list A) : rev xs = nil -> xs = nil. 80 | destruct xs as [ | x xs ]; auto. 81 | intro IH; absurd (rev (x :: xs) = nil); auto. 82 | simpl; apply appendNonNil. 83 | Qed. 84 | 85 | 86 | Lemma revStep (A : Set) (xs : list A) (x : A) : rev xs ++ x :: nil = rev (x :: xs). 87 | reflexivity. 88 | Qed. -------------------------------------------------------------------------------- /src/Extraction.v: -------------------------------------------------------------------------------- 1 | 2 | Require Import Arith List Program Decidable Sumbool Logic. 3 | Require Import StackSet. 4 | Extraction Language Haskell. 5 | 6 | Extract Constant StackSet.FMap "a" "b" => "M.Map a b". 7 | Extract Constant StackSet.empty => "M.empty". 8 | Extract Constant StackSet.insert => "M.insert". 9 | Extract Constant StackSet.remove => "M.delete". 10 | Extract Constant StackSet.r => "Rational". 11 | 12 | Extract Inductive unit => "()" [ "()" ]. 13 | 14 | Extract Inductive bool => "Bool" [ "True" "False" ]. 15 | Extract Inductive sumbool => "Bool" [ "True" "False" ]. 16 | Extract Constant orb => "(||)". 17 | Extract Constant andb => "(&&)". 18 | Extract Constant negb => "not". 19 | Extraction Inline orb negb andb bool_of_sumbool StackSet.beqi StackSet.beqa. 20 | 21 | Extract Inductive list => "List" [ "[]" "(:)" ]. 22 | Extract Inlined Constant tl => "tail". 23 | 24 | (* These don't work yet?*) 25 | (* Extract Constant rev => "reverse". *) 26 | (* Extraction Inline rev. *) 27 | (* filter flat_map splitAt zipWith3 *) 28 | Extract Inlined Constant Datatypes.length => "length". 29 | Extract Inlined Constant Coq.Lists.List.filter => "filter". 30 | Extract Inlined Constant app => "(++)". 31 | Extract Inlined Constant List.map => "map". 32 | Extract Inlined Constant last => "last". 33 | Extraction Inline last. 34 | 35 | Extract Inductive option => "Maybe" [ "Just" "Nothing" ]. 36 | Extract Constant option_rect => "flip maybe". 37 | Extraction Inline option_rect option_rec. 38 | (* What about maybe option_bind *) 39 | 40 | Extract Inductive prod => "(,)" [ "(,)" ]. 41 | Extract Constant fst => "fst". 42 | Extract Constant snd => "snd". 43 | Extraction Inline fst snd. 44 | 45 | Extraction Inline id proj1_sig sumbool_rec sumbool_rect. 46 | Extraction Inline eq_rect eq_rec eq_rec_r. 47 | 48 | Extract Constant eq_nat_dec => "(==)". 49 | Extraction Inline eq_nat_dec. 50 | 51 | Extract Inductive Datatypes.nat => "Int" ["0" "succ"] 52 | "(\fO fS n -> if n==0 then fO () else fS (n-1))". 53 | 54 | Extract Inductive StackSet.stackSet => "StackSet" ["StackSet"]. 55 | Extract Inductive StackSet.workspace => "Workspace" ["Workspace"]. 56 | Extract Inductive StackSet.rationalRect => "RationalRect" ["RationalRect"]. 57 | Extract Inductive StackSet.screen => "Screen" ["Screen"]. 58 | Extract Inductive StackSet.stack => "Stack" ["Stack"]. 59 | Extract Constant StackSet.beqsid => "(==)". 60 | Extract Constant StackSet.eqsid => "(==)". 61 | Extraction Inline StackSet.beqsid StackSet.eqsid. 62 | 63 | Extraction "StackSet.hs" 64 | StackSet.new 65 | StackSet._view StackSet._greedyView 66 | StackSet.lookupWorkspace 67 | StackSet.screens StackSet.workspaces 68 | StackSet.screens StackSet.workspaces StackSet.allWindows StackSet.currentTag 69 | StackSet.peek StackSet.index StackSet.integrate StackSet.integrate' StackSet.differentiate 70 | StackSet.focusUp StackSet.focusDown StackSet.focusUp' StackSet.focusDown' StackSet.focusMaster 71 | StackSet._focusWindow 72 | StackSet._tagMember StackSet._renameTag StackSet._ensureTags StackSet._member 73 | StackSet._findTag 74 | StackSet.mapWorkspace StackSet.mapLayout 75 | StackSet._insertUp StackSet._delete StackSet._delete' StackSet.filterStack 76 | StackSet.swapUp StackSet.swapDown StackSet.swapMaster StackSet.shiftMaster 77 | StackSet.modify StackSet.modify' StackSet.float StackSet.sink 78 | StackSet._shift StackSet._shiftWin. 79 | 80 | (* Problems with Haskell extraction: 81 | - need type classes 82 | - better support for interfacing with libraries like Data.Map 83 | - limited control over generated data types (like strictness annotations) 84 | *) -------------------------------------------------------------------------------- /src/properties.txt: -------------------------------------------------------------------------------- 1 | [("StackSet invariants" , mytest prop_invariant) 2 | ,("empty: invariant" , mytest prop_empty_I) 3 | ,("empty is empty" , mytest prop_empty) 4 | ,("empty / current" , mytest prop_empty_current) 5 | ,("empty / member" , mytest prop_member_empty) 6 | ,("view : invariant" , mytest prop_view_I) 7 | ,("view sets current" , mytest prop_view_current) 8 | ,("view idempotent" , mytest prop_view_idem) 9 | ,("view reversible" , mytest prop_view_reversible) 10 | ,("view is local" , mytest prop_view_local) 11 | ,("greedyView : invariant" , mytest prop_greedyView_I) 12 | ,("greedyView sets current" , mytest prop_greedyView_current) 13 | ,("greedyView is safe " , mytest prop_greedyView_current_id) 14 | ,("greedyView idempotent" , mytest prop_greedyView_idem) 15 | ,("greedyView reversible" , mytest prop_greedyView_reversible) 16 | ,("greedyView is local" , mytest prop_greedyView_local) 17 | ,("peek/member " , mytest prop_member_peek) 18 | ,("index/length" , mytest prop_index_length) 19 | ,("focus master : invariant", mytest prop_focusMaster_I) 20 | ,("focusWindow: invariant", mytest prop_focus_I) 21 | ,("focus left/master" , mytest prop_focus_left_master) 22 | ,("focus right/master" , mytest prop_focus_right_master) 23 | ,("focus master/master" , mytest prop_focus_master_master) 24 | ,("focusWindow master" , mytest prop_focusWindow_master) 25 | ,("focus all left " , mytest prop_focus_all_l) 26 | ,("focus all right " , mytest prop_focus_all_r) 27 | ,("focus master idemp" , mytest prop_focusMaster_idem) 28 | ,("focusWindow is local", mytest prop_focusWindow_local) 29 | ,("focusWindow works" , mytest prop_focusWindow_works) 30 | ,("focusWindow identity", mytest prop_focusWindow_identity) 31 | ,("findTag" , mytest prop_findIndex) 32 | ,("allWindows/member" , mytest prop_allWindowsMember) 33 | ,("currentTag" , mytest prop_currentTag) 34 | ,("insert: invariant" , mytest prop_insertUp_I) 35 | ,("insert/new" , mytest prop_insert_empty) 36 | ,("insert is idempotent", mytest prop_insert_idem) 37 | ,("insert is reversible", mytest prop_insert_delete) 38 | ,("insert duplicates" , mytest prop_insert_duplicate) 39 | ,("insert/peek " , mytest prop_insert_peek) 40 | ,("insert/size" , mytest prop_size_insert) 41 | ,("delete: invariant" , mytest prop_delete_I) 42 | ,("delete/empty" , mytest prop_empty) 43 | ,("delete/member" , mytest prop_delete) 44 | ,("delete is reversible", mytest prop_delete_insert) 45 | ,("delete is local" , mytest prop_delete_local) 46 | ,("delete/focus" , mytest prop_delete_focus) 47 | ,("delete last/focus up", mytest prop_delete_focus_end) 48 | ,("delete ~last/focus down", mytest prop_delete_focus_not_end) 49 | ,("filter preserves order", mytest prop_filter_order) 50 | ,("swapUp: invariant" , mytest prop_swap_left_I) 51 | ,("swapDown: invariant", mytest prop_swap_right_I) 52 | ,("swapUp id on focus", mytest prop_swap_left_focus) 53 | ,("swap all left " , mytest prop_swap_all_l) 54 | ,("swap all right " , mytest prop_swap_all_r) 55 | ,("shiftMaster id on focus", mytest prop_shift_master_focus) 56 | ,("shiftMaster is idempotent", mytest prop_shift_master_idempotent) 57 | ,("shiftMaster preserves ordering", mytest prop_shift_master_ordering) 58 | ,("shift: invariant" , mytest prop_shift_I) 59 | ,("shift is reversible" , mytest prop_shift_reversible) 60 | ,("shiftWin: invariant" , mytest prop_shift_win_I) 61 | ,("shiftWin is shift on focus" , mytest prop_shift_win_focus) 62 | ,("shiftWin fix current" , mytest prop_shift_win_fix_current) 63 | ,("floating is reversible" , mytest prop_float_reversible) 64 | ,("floating sets geometry" , mytest prop_float_geometry) 65 | ,("floats can be deleted", mytest prop_float_delete) 66 | ,("screens includes current", mytest prop_screens) 67 | ,("lookupTagOnScreen", mytest prop_lookup_current) 68 | ,("lookupTagOnVisbleScreen", mytest prop_lookup_visible) 69 | ,("screens works", mytest prop_screens_works) 70 | ,("renaming works", mytest prop_rename1) 71 | ,("ensure works", mytest prop_ensure) 72 | ,("ensure hidden semantics", mytest prop_ensure_append) 73 | ,("shiftWin identity", mytest prop_shift_win_indentity) 74 | -------------------------------------------------------------------------------- /src/StackSetHeader.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : XMonad.StackSet 4 | -- Copyright : (c) Don Stewart 2007 5 | -- License : BSD3-style (see LICENSE) 6 | -- 7 | -- Maintainer : dons@galois.com 8 | -- Stability : experimental 9 | -- Portability : portable, Haskell 98 10 | -- 11 | 12 | module XMonad.StackSet ( 13 | -- * Introduction 14 | -- $intro 15 | 16 | -- ** The Zipper 17 | -- $zipper 18 | 19 | -- ** Xinerama support 20 | -- $xinerama 21 | 22 | -- ** Master and Focus 23 | -- $focus 24 | 25 | StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..), ScreenId(..), 26 | -- * Construction 27 | -- $construction 28 | new, 29 | view, greedyView, 30 | -- * Xinerama operations 31 | -- $xinerama 32 | lookupWorkspace, 33 | screens, workspaces, allWindows, currentTag, 34 | -- * Operations on the current stack 35 | -- $stackOperations 36 | peek, index, integrate, integrate', differentiate, 37 | focusUp, focusDown, focusUp', focusDown', focusMaster, focusWindow, 38 | tagMember, renameTag, ensureTags, member, findTag, mapWorkspace, mapLayout, 39 | -- * Modifying the stackset 40 | -- $modifyStackset 41 | insertUp, delete, delete', filterStack, 42 | -- * Setting the master window 43 | -- $settingMW 44 | swapUp, swapDown, swapMaster, shiftMaster, modify, modify', float, sink, 45 | -- * Composite operations 46 | -- $composite 47 | shift, shiftWin, 48 | 49 | -- for testing 50 | abort 51 | ) where 52 | 53 | import qualified Prelude (until,last,maybe,splitAt,zipWith3) 54 | import Prelude hiding (until,last,maybe,seq,splitAt,zipWith3) 55 | import Data.Maybe hiding (maybe) 56 | import qualified Data.List as L (deleteBy,find,splitAt,filter,nub) 57 | import Data.List ( (\\) ) 58 | import qualified Data.Map as M (Map,insert,delete,empty) 59 | 60 | ------------------------------------------------------------------------ 61 | -- | 62 | -- A cursor into a non-empty list of workspaces. 63 | -- 64 | -- We puncture the workspace list, producing a hole in the structure 65 | -- used to track the currently focused workspace. The two other lists 66 | -- that are produced are used to track those workspaces visible as 67 | -- Xinerama screens, and those workspaces not visible anywhere. 68 | 69 | data StackSet i l a sd = 70 | StackSet { current :: !(Screen i l a sd) -- ^ currently focused workspace 71 | , visible :: [Screen i l a sd] -- ^ non-focused workspaces, visible in xinerama 72 | , hidden :: [Workspace i l a] -- ^ workspaces not visible anywhere 73 | , floating :: M.Map a RationalRect -- ^ floating windows 74 | } deriving (Show, Read, Eq) 75 | 76 | -- | Visible workspaces, and their Xinerama screens. 77 | data Screen i l a sd = Screen { workspace :: !(Workspace i l a) 78 | , screen :: !ScreenId 79 | , screenDetail :: !sd } 80 | deriving (Show, Read, Eq) 81 | 82 | -- | 83 | -- A workspace is just a tag, a layout, and a stack. 84 | -- 85 | data Workspace i l a = Workspace { tag :: !i, layout :: l, stack :: Maybe (Stack a) } 86 | deriving (Show, Read, Eq) 87 | 88 | -- | A structure for window geometries 89 | data RationalRect = 90 | RationalRect Rational Rational Rational Rational 91 | deriving (Show, Read, Eq) 92 | 93 | -- | 94 | -- A stack is a cursor onto a (possibly empty) window list. 95 | -- The data structure tracks focus by construction, and 96 | -- the master window is by convention the top-most item. 97 | -- Focus operations will not reorder the list that results from 98 | -- flattening the cursor. The structure can be envisaged as: 99 | -- 100 | -- > +-- master: < '7' > 101 | -- > up | [ '2' ] 102 | -- > +--------- [ '3' ] 103 | -- > focus: < '4' > 104 | -- > dn +----------- [ '8' ] 105 | -- 106 | -- A 'Stack' can be viewed as a list with a hole punched in it to make 107 | -- the focused position. Under the zipper\/calculus view of such 108 | -- structures, it is the differentiation of a [a], and integrating it 109 | -- back has a natural implementation used in 'index'. 110 | -- 111 | data Stack a = Stack { up :: [a] -- clowns to the left 112 | , focus :: !a -- focused thing in this set 113 | , down :: [a] } -- jokers to the right 114 | deriving (Show, Read, Eq) 115 | 116 | 117 | type ScreenId = Int 118 | 119 | -- | this function indicates to catch that an error is expected 120 | abort :: String -> a 121 | abort x = error $ "xmonad: StackSet: " ++ x 122 | 123 | type List a = [a] 124 | ----------------------------------------------------------------------- 125 | 126 | findTag :: Eq a => a -> StackSet i l a s -> Maybe i 127 | findTag = _findTag (==) 128 | 129 | member :: Eq a => a -> StackSet i l a s -> Bool 130 | member = _member (==) 131 | 132 | view :: (Eq i) => i -> StackSet i l a s-> StackSet i l a s 133 | view = _view (==) 134 | 135 | greedyView :: (Eq i) => i -> StackSet i l a s -> StackSet i l a s 136 | greedyView = _greedyView (==) 137 | 138 | focusWindow :: (Eq a, Eq i) => a -> StackSet i l a s -> StackSet i l a s 139 | focusWindow = _focusWindow (==) (==) 140 | 141 | tagMember :: Eq i => i -> StackSet i l a s -> Bool 142 | tagMember = _tagMember (==) 143 | 144 | renameTag :: Eq i => i -> i -> StackSet i l a s -> StackSet i l a s 145 | renameTag = _renameTag (==) 146 | 147 | ensureTags :: Eq i => l -> [i] -> StackSet i l a s -> StackSet i l a s 148 | ensureTags = _ensureTags (==) 149 | 150 | insertUp :: Eq a => a -> StackSet i l a s -> StackSet i l a s 151 | insertUp = _insertUp (==) 152 | 153 | delete :: (Ord a, Eq s) => a -> StackSet i l a s -> StackSet i l a s 154 | delete = _delete (==) 155 | 156 | delete' :: (Eq a) => a -> StackSet i l a s -> StackSet i l a s 157 | delete' = _delete' (==) 158 | 159 | shiftWin :: (Eq a, Eq i) => i -> a -> StackSet i l a s -> StackSet i l a s 160 | shiftWin = _shiftWin (==) (==) 161 | 162 | shift :: (Ord a, Eq i) => i -> StackSet i l a s -> StackSet i l a s 163 | shift = _shift (==) (==) 164 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## v # The Coq Proof Assistant ## 3 | ## "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) 181 | 182 | byte: 183 | $(MAKE) all "OPT:=-byte" 184 | 185 | opt: 186 | $(MAKE) all "OPT:=-opt" 187 | 188 | install: 189 | mkdir -p $(COQLIB)/user-contrib 190 | (for i in $(VOFILES0); do \ 191 | install -d `dirname $(COQLIB)/user-contrib/$(INSTALLDEFAULTROOT)/$$i`; \ 192 | install $$i $(COQLIB)/user-contrib/$(INSTALLDEFAULTROOT)/$$i; \ 193 | done) 194 | 195 | clean: 196 | rm -f $(CMOFILES) $(CMIFILES) $(CMXFILES) $(CMXSFILES) $(OFILES) $(VOFILES) $(VIFILES) $(GFILES) $(HSFILE) $(MLFILES:.ml=.cmo) $(MLFILES:.ml=.cmx) *~ 197 | rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(HTMLFILES) $(GHTMLFILES) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) $(VFILES:.v=.v.d) 198 | rm -rf html $(BUILDDIR) 199 | 200 | archclean: 201 | rm -f *.cmx *.o 202 | 203 | $(BUILDDIR)/xmonad-0.10.tar.gz: 204 | mkdir -p $(BUILDDIR) 205 | curl http://hackage.haskell.org/packages/archive/xmonad/0.10/xmonad-0.10.tar.gz\ 206 | -o $(BUILDDIR)/xmonad-0.10.tar.gz 207 | 208 | $(BUILDDIR)/xmonad-0.10/xmonad.cabal: $(BUILDDIR)/xmonad-0.10.tar.gz 209 | mkdir -p $(BUILDDIR) 210 | cd $(BUILDDIR); tar zxf xmonad-0.10.tar.gz 211 | patch $(XMONADDIR)/xmonad.cabal -i scripts/cabal.patch 212 | patch $(XMONADDIR)/XMonad/Core.hs -i scripts/core.patch 213 | patch $(XMONADDIR)/XMonad/Operations.hs -i scripts/operations.patch 214 | patch $(XMONADDIR)/tests/Properties.hs -i scripts/properties.patch 215 | 216 | extraction: $(BUILDDIR)/xmonad-0.10/xmonad.cabal 217 | mkdir -p $(BUILDDIR) 218 | $(MAKE) all 219 | $(COQC) $(COQFLAGS) $(EXTRACTION_FILE) 220 | cp $(HSHEADER) $(XMONADDIR)/XMonad/$(HSFILE) 221 | sed -f $(SEDSCRIPT) $(HSFILE) >> $(XMONADDIR)/XMonad/$(HSFILE) 222 | rm $(HSFILE) 223 | 224 | integration: extraction 225 | cd $(XMONADDIR); cabal configure --flags="testing"; cabal build 226 | 227 | quickcheck: integration 228 | cd $(XMONADDIR); dist/build/xmonad/xmonad --run-tests 229 | 230 | theorems: 231 | @echo -n 'Total theorems stated: ' 232 | @grep Theorem src/Properties.v | wc -l 233 | @echo -n 'Total theorems admitted: ' 234 | @grep Admitted src/Properties.v | wc -l 235 | @echo -n 'Remaing theorems: ' 236 | @wc -l src/properties.txt 237 | printenv: 238 | @echo CAMLC = $(CAMLC) 239 | @echo CAMLOPTC = $(CAMLOPTC) 240 | @echo CAMLP4LIB = $(CAMLP4LIB) 241 | 242 | # WARNING 243 | # 244 | # This Makefile has been automagically generated 245 | # Edit at your own risks ! 246 | # 247 | # END OF WARNING 248 | 249 | -------------------------------------------------------------------------------- /src/ListLemmas.v: -------------------------------------------------------------------------------- 1 | Require Import Aux List. 2 | Require Import Arith. 3 | Require Import Sorting.Permutation. 4 | 5 | Lemma NoDupSingle : forall (a : Type) (x : a), 6 | NoDup (x :: nil). 7 | Proof. constructor; auto; constructor. Qed. 8 | 9 | Lemma NoDupCons : forall (a : Type) (xs : list a) (x : a), 10 | NoDup (x :: xs) -> NoDup xs. 11 | Proof. 12 | intros a xs x H; induction xs. 13 | constructor. inversion H; assumption. 14 | Qed. 15 | 16 | Lemma InApp : forall (a : Type) (x : a) (xs ys : list a), 17 | In x (xs ++ x :: ys). 18 | Proof. 19 | intros a x xs. 20 | induction xs. 21 | simpl; constructor; reflexivity. 22 | intros ys. right. apply IHxs. 23 | Qed. 24 | 25 | Lemma InApp' : forall (a : Type) (x y : a) (xs ys : list a), 26 | In x (xs ++ ys) -> In x (xs ++ y :: ys). 27 | Proof. 28 | intros a x y xs ys H. 29 | generalize dependent ys. 30 | induction xs. 31 | right; assumption. 32 | intros ys H. destruct H as [H | H]. 33 | rewrite H; constructor; reflexivity. 34 | right; apply IHxs; assumption. 35 | Qed. 36 | 37 | Lemma InSuper : forall (a : Type) (x : a) (xs ys : list a), 38 | In x xs -> In x (xs ++ ys). 39 | Proof. 40 | intros a x xs ys H. 41 | generalize dependent ys. 42 | induction xs as [ | z zs]. 43 | inversion H. 44 | inversion H. 45 | constructor; exact H0. 46 | destruct H as [Eq | Later]. 47 | constructor; exact Eq. 48 | right. apply (IHzs); auto. 49 | Qed. 50 | 51 | Lemma InComm : forall (a : Type) (x : a) (xs ys : list a), 52 | In x (xs ++ ys) -> In x (ys ++ xs). 53 | Proof. 54 | intros a x xs ys. 55 | generalize dependent ys. 56 | induction xs as [ | z zs]. 57 | intros ys H. simpl;rewrite app_nil_r; intros; assumption. 58 | intros ys H. destruct H as [H | H]. 59 | rewrite H. 60 | apply InApp. 61 | apply InApp'. 62 | apply IHzs. 63 | assumption. 64 | Qed. 65 | 66 | Lemma NotInComm : forall (a : Type) (x : a) (xs ys : list a), 67 | ~In x (xs ++ ys) -> ~In x (ys ++ xs). 68 | Proof. 69 | intros a x xs ys F H. 70 | induction ys as [ | y ys]. 71 | induction xs as [ | z zs]; auto. 72 | rewrite app_nil_r in F; simpl in *; contradiction. 73 | destruct H as [H | H]. 74 | rewrite H in *; apply F, InApp; assumption. 75 | apply F, InApp', InComm; auto. 76 | Qed. 77 | 78 | Lemma NoDupAppAss : forall (a : Type) (xs ys : list a), 79 | NoDup (xs ++ ys) -> NoDup (ys ++ xs). 80 | Proof. 81 | intros a xs ys H. 82 | generalize dependent xs. 83 | induction ys. 84 | intros xs H. 85 | rewrite app_nil_r in H; assumption. 86 | constructor; 87 | [ apply NotInComm, NoDup_remove_2; assumption 88 | | apply IHys; apply NoDup_remove_1 in H; assumption]. 89 | Qed. 90 | 91 | Lemma NoDupPerm : forall (a : Type) (xs ys : list a), 92 | NoDup xs -> Permutation xs ys -> NoDup ys. 93 | Proof. 94 | intros a xs ys H1 H2. 95 | induction H2. 96 | (* nil *) 97 | constructor. 98 | (* skip *) 99 | constructor. 100 | intro F; apply (NoDup_remove_2 nil l x); auto. 101 | apply (Permutation_in (l:=l')); 102 | [ apply (Permutation_sym) | ]; auto. 103 | apply IHPermutation. 104 | inversion H1; auto. 105 | (* swap *) 106 | constructor. 107 | apply (NoDup_remove_2 (y :: nil) l x); auto. 108 | apply (NoDup_remove_1 (y :: nil) l x); auto. 109 | (* trans *) 110 | apply IHPermutation2,IHPermutation1; auto. 111 | Qed. 112 | 113 | Lemma PermAppL : forall (a : Type) (xs ys zs : list a), 114 | Permutation ys zs -> Permutation (xs ++ ys) (xs ++ zs). 115 | Proof. 116 | intros a xs ys zs H1. 117 | generalize dependent ys. 118 | generalize dependent zs. 119 | induction xs; [auto | simpl; auto]. 120 | Qed. 121 | 122 | Lemma PermAppR : forall (a : Type) (xs ys zs : list a), 123 | Permutation ys zs -> Permutation (ys ++ xs) (zs ++ xs). 124 | Proof. 125 | intros a xs ys zs H. 126 | induction xs as [| x xs IHxs]. 127 | do 2 rewrite -> app_nil_r; apply H. 128 | apply Permutation_add_inside. apply H. 129 | apply Permutation_refl. 130 | Qed. 131 | 132 | Lemma NoDupConsSwap : forall (a : Type) (xs : list a) (x y : a), 133 | NoDup (x :: y :: xs) -> NoDup (y :: x :: xs). 134 | Proof. 135 | intros a xs x y H. 136 | apply (NoDupPerm _ (x :: y :: xs) (y :: x :: xs)). 137 | apply H. constructor. 138 | Qed. 139 | 140 | Lemma NoDupAppConsR : forall (a : Type) (xs ys : list a) (x : a), 141 | NoDup (xs ++ x :: ys) -> NoDup (xs ++ ys). 142 | Proof. 143 | intros a xs ys x H1. 144 | apply NoDupAppAss. 145 | apply (NoDupCons _ (ys ++ xs) x). 146 | rewrite -> app_comm_cons. 147 | apply NoDupAppAss. 148 | apply H1. 149 | Qed. 150 | 151 | Lemma NoDupAppR : forall (a : Type) (xs ys : list a), 152 | NoDup (xs ++ ys) -> NoDup ys. 153 | Proof. 154 | intros a xs ys H1. 155 | generalize dependent ys. 156 | induction xs as [| x xs IHxs]. 157 | intros ys H1. 158 | destruct ys as [| y ys]. 159 | apply H1. 160 | apply H1. 161 | intros ys H1. 162 | simpl in H1. 163 | apply IHxs. 164 | apply NoDupCons in H1; apply H1. 165 | Qed. 166 | 167 | Lemma NoDupAppL : forall (a : Type) (xs ys : list a), 168 | NoDup (xs ++ ys) -> NoDup xs. 169 | Proof. 170 | intros a xs ys H. 171 | apply NoDupAppAss in H. 172 | apply (NoDupAppR _ ys xs). 173 | apply H. 174 | Qed. 175 | 176 | Lemma FlatMapApp : forall (a b : Type) (f : a -> list b) (xs ys : list a), 177 | flat_map f (xs ++ ys) = flat_map f xs ++ flat_map f ys. 178 | Proof. 179 | intros a b f xs. 180 | induction xs as [| x xs IHxs]. reflexivity. 181 | intros ys. simpl. rewrite -> IHxs. 182 | rewrite -> app_ass. reflexivity. 183 | Qed. 184 | 185 | Lemma NoDupFlatMapCons : forall (a b : Type) (x : a) (xs : list a) (f : a -> list b), 186 | NoDup (flat_map f (x :: xs)) -> NoDup (flat_map f xs). 187 | Proof. 188 | intros a b x xs f H. 189 | destruct xs as [| y ys ]. constructor. 190 | apply (NoDupAppR _ (f x) (f y ++ flat_map f ys)). 191 | assumption. 192 | Qed. 193 | 194 | Lemma PermutationFlatMap : forall (a b : Type) (f : a -> list b) (xs ys : list a), 195 | Permutation xs ys -> Permutation (flat_map f xs) (flat_map f ys). 196 | Proof. 197 | intros a b f xs ys H. 198 | induction H. 199 | constructor. 200 | simpl. apply Permutation_app_head. apply IHPermutation. 201 | simpl. do 2 rewrite -> app_assoc. 202 | apply Permutation_app_tail. apply Permutation_app_comm. 203 | generalize IHPermutation2. 204 | generalize IHPermutation1. 205 | apply Permutation_trans. 206 | Qed. 207 | 208 | Lemma NoDupFlatMap : forall (a b : Type) (xs ys : list a) (f : a -> list b), 209 | NoDup (flat_map f xs) -> Permutation xs ys -> NoDup (flat_map f ys). 210 | Proof. 211 | intros a b xs ys f H1 H2. 212 | destruct ys as [| y ys ]. 213 | constructor. 214 | apply (NoDupPerm _ _ _ H1). 215 | apply PermutationFlatMap. 216 | apply H2. 217 | Qed. 218 | 219 | Lemma NoDupFlatMapApp : forall (a b : Type) (xs ys : list a) (f : a -> list b), 220 | NoDup (flat_map f (xs ++ ys)) -> NoDup (flat_map f xs ++ flat_map f ys). 221 | Proof. 222 | intros a b xs ys f H. 223 | rewrite <- FlatMapApp. 224 | apply H. 225 | Qed. 226 | 227 | Lemma NoDupAppFlatMap : forall (a b : Type) (xs ys : list a) (f : a -> list b), 228 | NoDup (flat_map f xs ++ flat_map f ys) -> NoDup (flat_map f (xs ++ ys)). 229 | Proof. 230 | intros a b xs ys f H. 231 | rewrite -> FlatMapApp. 232 | apply H. 233 | Qed. 234 | 235 | Lemma NotInCons : forall (a : Type) (x y : a) (ys : list a), 236 | ~ In x (y :: ys) -> ~ In x ys. 237 | Proof. 238 | unfold not. 239 | intros a x y ys H1 H2. 240 | apply H1. apply in_cons. apply H2. 241 | Qed. 242 | 243 | Lemma NoDupNotIn : forall (a : Type) (x : a) (xs : list a), 244 | NoDup (x :: xs) -> ~ In x xs. 245 | Proof. 246 | intros a x xs H1. 247 | induction xs as [| x' xs IHxs]. 248 | apply in_nil. 249 | unfold not in *. 250 | intros H2. 251 | apply IHxs. 252 | apply (NoDupCons _ (x :: xs) x'). 253 | apply NoDupConsSwap; apply H1. 254 | Admitted. 255 | 256 | Lemma NotInApp : forall (a : Type) (x : a) (xs ys : list a), 257 | ~In x xs -> ~In x ys -> ~In x (xs ++ ys). 258 | Proof. 259 | unfold not. 260 | intros a x xs ys H1 H2 H3. 261 | induction xs as [| x' xs IHxs ]. 262 | apply H2; apply H3. 263 | induction ys as [| y ys IHys]. 264 | apply H1. rewrite -> app_nil_r in H3. apply H3. 265 | apply IHxs. 266 | apply (NotInCons _ x x' xs). unfold not. apply H1. 267 | Admitted. 268 | 269 | Lemma NoDupFlatMapL : forall (a b : Type) (f : a -> list b) (xs : list a), 270 | NoDup (flat_map f xs) -> NoDup xs. 271 | Proof. 272 | intros a b f xs H. 273 | induction xs as [| x xs IHxs ]. 274 | constructor. 275 | constructor. 276 | Admitted. 277 | 278 | Lemma HdTlNotNil (a : Type) (x : a) (xs : list a) : 279 | xs <> nil -> hd x xs :: (tl xs) = xs. 280 | Proof. 281 | intros F; induction xs. 282 | exfalso; apply F; reflexivity. 283 | reflexivity. 284 | Qed. 285 | -------------------------------------------------------------------------------- /src/StackSet.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | List Program Decidable Sumbool. 3 | 4 | Set Implicit Arguments. 5 | 6 | Section StackSet_defs. 7 | 8 | Require Import Aux. 9 | 10 | (******************************************************************* 11 | ** Variables corresponding to type classes ** 12 | *******************************************************************) 13 | 14 | Variable (i l a sd : Set). 15 | 16 | Variable eqi : forall (x y : i), {x = y} + {x <> y}. 17 | Definition beqi (x y : i) : {b : bool | if b then x = y else x <> y} 18 | := bool_of_sumbool (eqi x y). 19 | 20 | Variable eqa : forall (x y : a), {x = y} + {x <> y}. 21 | Definition beqa (x y : a) : {b : bool | if b then x = y else x <> y} 22 | := bool_of_sumbool (eqa x y). 23 | 24 | Definition eqOption : forall (x y : option a), {x = y} + {x <> y}. 25 | decide equality; apply eqa. 26 | Defined. 27 | 28 | Definition beqOption (x y : option a) : {b : bool | if b then x = y else x <> y} 29 | := bool_of_sumbool (eqOption x y). 30 | 31 | (******************************************************************* 32 | ** Axiomatic assumptions about Data.Map ** 33 | *******************************************************************) 34 | 35 | Axiom FMap : Set -> Set -> Set. 36 | Axiom empty : forall k a, FMap k a. 37 | Axiom insert : forall (k a : Set), k -> a -> FMap k a -> FMap k a. 38 | Axiom remove : forall (k a : Set), k -> FMap k a -> FMap k a. 39 | Axiom r : Set. 40 | 41 | (******************************************************************* 42 | ** Data types for stacksets ** 43 | *******************************************************************) 44 | 45 | Definition sid : Set := nat. 46 | 47 | Definition eqsid (x y : sid) : {x = y} + {x <> y}. 48 | decide equality. 49 | Defined. 50 | 51 | Definition beqsid (x y : sid) : {b : bool | if b then x = y else x <> y} 52 | := bool_of_sumbool (eqsid x y). 53 | 54 | Record stack : Set := 55 | Stack 56 | { getUp : list a 57 | ; getFocus : a 58 | ; getDown : list a 59 | }. 60 | 61 | Record workspace : Set := 62 | Workspace 63 | { getTag : i 64 | ; getLayout : l 65 | ; getStack : option stack 66 | }. 67 | 68 | Inductive rationalRect : Set := 69 | RationalRect : r -> r -> r -> r -> rationalRect. 70 | 71 | Record screen : Set := 72 | Screen 73 | { getWorkspace : workspace 74 | ; getScreen : sid 75 | ; getScreenDetail : sd 76 | }. 77 | 78 | Record stackSet : Set := 79 | StackSet 80 | { getCurrent : screen 81 | ; getVisible : list screen 82 | ; getHidden : list workspace 83 | ; getFloating : FMap a rationalRect 84 | }. 85 | 86 | (******************************************************************* *) 87 | (* ** Functions from StackSet.hs re-implemented in Coq ** *) 88 | (* *******************************************************************) 89 | 90 | Definition workspaces : stackSet -> list workspace := 91 | fun s => (getWorkspace (getCurrent s)) :: 92 | map (fun x => getWorkspace x) (getVisible s) ++ getHidden s. 93 | 94 | Definition new 95 | (m : l) 96 | (wids : {wids : list i | wids <> nil }) 97 | (sds : {sds : list sd | length sds <= length (proj1_sig wids) /\ sds <> nil}) 98 | : stackSet. 99 | refine ( 100 | let seenUnseen := splitAt (length (proj1_sig sds)) (map (fun i => Workspace i m None) (proj1_sig wids)) 101 | in let zippy := zipWith3 Screen 102 | (fst seenUnseen) 103 | (seq 0 (length (proj1_sig wids))) 104 | (proj1_sig sds) 105 | in match zippy return (zippy = zipWith3 Screen 106 | (fst seenUnseen) 107 | (seq 0 (length (proj1_sig wids))) 108 | (proj1_sig sds) -> stackSet) with 109 | | (cur :: visi) => fun _ => 110 | StackSet cur visi (snd seenUnseen) (empty a rationalRect) 111 | | nil => _ 112 | end _). 113 | intro H. 114 | destruct wids as ([ | wid wids] & prf). 115 | contradiction prf; auto. 116 | destruct sds as ( [ | sid sids] & (H1 & H2)). 117 | contradiction H2; auto. 118 | unfold seenUnseen in H. 119 | simpl in H. 120 | discriminate H. 121 | unfold zippy; auto. 122 | Defined. 123 | 124 | Definition currentTag : stackSet -> i := 125 | fun s => getTag (getWorkspace (getCurrent s)). 126 | 127 | Definition _tagMember (x : i) (stckset : stackSet) : 128 | let tags := map getTag (workspaces stckset) 129 | in {In x tags} + {~In x tags} := 130 | let tags := map getTag (workspaces stckset) 131 | in In_dec (A := i) eqi x tags. 132 | 133 | Definition _view 134 | (x : i) (s : stackSet) : stackSet := 135 | match eqi x (currentTag s) with 136 | | left eq => s 137 | | _ => 138 | match find (fun y => proj1_sig (beqi x (getTag (getWorkspace y)))) (getVisible s) with 139 | | Some x => 140 | match s with 141 | StackSet c vs us f => 142 | let p x y := proj1_sig (beqsid (getScreen x) (getScreen y)) in 143 | StackSet x (deleteBy p x vs) us f 144 | end 145 | | _ => 146 | match find (fun y => proj1_sig (beqi x (getTag y))) (getHidden s) with 147 | | Some x => 148 | match s with 149 | | StackSet c vs us f => 150 | let c' := match c with 151 | | Screen _ sid sd => Screen x sid sd 152 | end 153 | in let p x y := proj1_sig (beqi (getTag x) (getTag y)) in 154 | StackSet c' vs (getWorkspace c :: deleteBy p x us) f 155 | end 156 | | None => s 157 | end 158 | end 159 | end. 160 | 161 | Definition _greedyView (w : i) (ws : stackSet) : stackSet := 162 | let wTag x := proj1_sig (beqi w (getTag x)) 163 | in if existsb wTag (getHidden ws) then _view w ws 164 | else match find (fun x => wTag (getWorkspace x)) (getVisible ws) with 165 | | None => ws 166 | | Some s => match ws with 167 | | StackSet c vs us f => 168 | let c' := c 169 | in let vs' := 170 | match s with 171 | | Screen w sid sd => 172 | Screen (getWorkspace (getCurrent ws)) sid sd 173 | :: filter (fun x => negb (wTag (getWorkspace x))) vs 174 | end 175 | in StackSet c' vs' us f 176 | end 177 | end. 178 | 179 | Definition lookupWorkspace (sc : sid) (w : stackSet) : option i := 180 | let ws := filter (fun w => proj1_sig (beqsid sc (getScreen w))) 181 | (getCurrent w :: getVisible w) 182 | in match ws with 183 | | nil => None 184 | | (Screen y _ _ :: _) => Some (getTag y) 185 | end. 186 | 187 | (* Called "with" in StackSet.hs *) 188 | Definition withStack : forall b, 189 | b -> (stack -> b) -> stackSet -> b := 190 | fun b y f s => 191 | maybe y f (getStack (getWorkspace (getCurrent s))). 192 | 193 | Definition modify : 194 | option stack -> (stack -> option stack) 195 | -> stackSet -> stackSet := 196 | fun d f s => 197 | match s with 198 | StackSet (Screen (Workspace i l x) sid sd) v h m => 199 | StackSet (Screen (Workspace i l (withStack d f s)) sid sd) v h m end. 200 | 201 | Definition modify' : 202 | (stack -> stack) -> stackSet -> stackSet := 203 | fun f => modify None (fun x => Some (f x)). 204 | 205 | Definition peek : stackSet -> option a := 206 | withStack None (fun x => Some (getFocus x)). 207 | 208 | Definition integrate : stack -> list a := 209 | fun s => match s with 210 | Stack u x d => rev u ++ x :: d 211 | end. 212 | 213 | Definition integrate' : option stack -> list a := 214 | fun s => maybe nil (fun x => integrate x) s. 215 | 216 | Definition differentiate : list a -> option stack := 217 | fun xs => match xs with 218 | | nil => None 219 | | y :: ys => Some (Stack nil y ys) 220 | end. 221 | 222 | (* Called filter in Xmonad *) 223 | Definition filterStack : 224 | (a -> bool) -> stack -> option stack := 225 | fun p s => match s with 226 | | Stack ls c rs => 227 | match filter p (c :: rs) with 228 | | c' :: rs' => Some (Stack (filter p ls) c' rs') 229 | | nil => match filter p ls with 230 | | c' :: ls' => Some (Stack ls' c' nil) 231 | | nil => None 232 | end 233 | end 234 | end. 235 | 236 | Definition index : stackSet -> list a := 237 | withStack nil (fun x => integrate x). 238 | 239 | Definition focusUp' : stack -> stack := 240 | fun s => match s with 241 | | Stack (l :: ls) c rs => Stack ls l (c :: rs) 242 | | Stack nil c rs => Stack (tail (rev (c :: rs))) (hd c (rev rs)) nil 243 | end. 244 | 245 | Definition swapUp' : stack -> stack := 246 | fun s => match s with 247 | | Stack (l :: ls) c rs => Stack ls c (l :: rs) 248 | | Stack nil c rs => Stack (rev rs) c nil 249 | end. 250 | 251 | Definition reverseStack : stack -> stack := 252 | fun s => match s with 253 | | Stack ls c rs => Stack rs c ls 254 | end. 255 | 256 | Definition focusUp : stackSet -> stackSet := 257 | fun s => modify' (fun x => focusUp' x) s. 258 | 259 | Definition focusDown' : stack -> stack := 260 | fun s => reverseStack (focusUp' (reverseStack s)). 261 | 262 | Definition focusDown : stackSet -> stackSet := 263 | fun s => modify' (fun x => focusDown' x) s. 264 | 265 | Definition swapUp : stackSet -> stackSet := 266 | fun s => modify' (fun x => swapUp' x) s. 267 | 268 | Definition swapDown : stackSet -> stackSet 269 | := fun s => modify' (fun x => reverseStack (swapUp' (reverseStack x))) s. 270 | 271 | Definition screens : stackSet -> list screen := 272 | fun s => getCurrent s :: getVisible s. 273 | 274 | Definition allWindows : stackSet -> list a := 275 | fun s => flat_map (fun x => integrate' (getStack x)) (workspaces s). 276 | 277 | Definition mapWorkspace : (workspace -> workspace) -> stackSet -> stackSet := 278 | fun f s => let updateScreen scr := match scr with 279 | | Screen w s sd => Screen (f w) s sd 280 | end 281 | in match s with 282 | | StackSet c v h fl => 283 | StackSet (updateScreen c) (map updateScreen v) (map f h) fl 284 | end. 285 | 286 | Definition _findTag : a -> stackSet -> option i := 287 | fun x s => 288 | let has := fun x opt => 289 | match opt with 290 | | None => false 291 | | Some (Stack ls c rs) => match In_dec eqa x (c :: ls ++ rs) with 292 | | left _ => true 293 | | right _ => false 294 | end 295 | end 296 | in match 297 | filter (fun w => has x (getStack w)) (workspaces s) with 298 | | nil => None 299 | | x :: _ => Some (getTag x) 300 | end. 301 | 302 | Definition _member : a -> stackSet -> bool := 303 | fun x s => 304 | match _findTag x s with 305 | | None => false 306 | | Some _ => true 307 | end. 308 | 309 | Definition _renameTag (old new : i) : stackSet -> stackSet := 310 | let rename := fun w => match eqi (getTag w) old with 311 | | left _ => Workspace new (getLayout w) (getStack w) 312 | | right _ => w 313 | end 314 | in mapWorkspace rename. 315 | 316 | Definition shiftMaster : stackSet -> stackSet := 317 | modify' (fun c => match c with 318 | | Stack nil _ _ => c 319 | | Stack ls t rs => Stack nil t (rev ls ++ rs) 320 | end). 321 | 322 | Definition focusMaster : stackSet -> stackSet. 323 | refine ( 324 | modify' (fun c => match c with 325 | | Stack [] _ _ => c 326 | | Stack (l :: ls) c rs => 327 | let revLs := rev (l :: ls) in 328 | match revLs return (rev (l :: ls) = revLs -> stack) with 329 | | nil => _ 330 | | x :: xs => fun _ => Stack nil x (xs ++ c :: rs) 331 | end _ 332 | end)). 333 | intro H; assert (D : l0 :: ls = nil); 334 | [apply revNil; auto | discriminate D]. 335 | auto. 336 | Defined. 337 | 338 | Definition rotate : list a -> list a := fun xs => 339 | match xs with 340 | | nil => nil 341 | | x :: xs => xs ++ [x] 342 | end. 343 | 344 | Definition swapMaster : stackSet -> stackSet := 345 | modify' (fun c => match c with 346 | | Stack nil _ _ => c 347 | | Stack ls c rs => 348 | let rs' := rotate (rev ls) ++ rs in 349 | Stack nil c rs' 350 | end). 351 | 352 | Definition _insertUp : a -> stackSet -> stackSet := 353 | fun x s => 354 | if _member x s 355 | then s 356 | else modify 357 | (Some (Stack nil x nil)) 358 | (fun s => match s with 359 | | Stack l c r => Some (Stack l x (c :: r)) 360 | end) s. 361 | 362 | Definition _ensureTags : l -> list i -> stackSet -> stackSet := 363 | fun label allt st => 364 | let fix et is rn s := 365 | match is , rn return stackSet with 366 | | nil , _ => s 367 | | i :: is , rn => 368 | match _tagMember i s with 369 | | left _ => et is rn s 370 | | right _ => 371 | match rn , s with 372 | | nil , StackSet c v h f => 373 | et is nil (StackSet c v (Workspace i label None :: h) f) 374 | | (r :: rs) , s => et is rs (_renameTag r i s) 375 | end 376 | end 377 | end 378 | in et allt 379 | (removeList eqi (map getTag (workspaces st)) allt) st. 380 | 381 | 382 | Definition sink : a -> stackSet -> stackSet := 383 | fun w s => match s with 384 | | StackSet c v h f => StackSet c v h (remove w f) 385 | end. 386 | 387 | Definition float : a -> rationalRect -> stackSet -> stackSet := 388 | fun w r s => match s with 389 | | StackSet c v h f => StackSet c v h (insert w r f) 390 | end. 391 | 392 | Definition _delete' : a -> stackSet -> stackSet := 393 | fun w s => 394 | let removeFromWorkspace ws := 395 | match ws with 396 | | Workspace i l stk => Workspace i l 397 | (option_bind stk (filterStack (fun x => negb (proj1_sig (beqa x w))))) 398 | end 399 | in let removeFromScreen scr := 400 | match scr with 401 | | Screen ws sid sd => Screen (removeFromWorkspace ws) sid sd 402 | end 403 | in match s with 404 | | StackSet c v h f => 405 | StackSet (removeFromScreen c) 406 | (map removeFromScreen v) 407 | (map removeFromWorkspace h) 408 | f 409 | end. 410 | 411 | Definition _delete : a -> stackSet -> stackSet := 412 | fun w s => sink w (_delete' w s). 413 | 414 | Definition _shift : i -> stackSet -> stackSet := 415 | fun n s => 416 | let curtag := getTag (getWorkspace (getCurrent s)) 417 | in let go w := _view curtag (_insertUp w (_view n (_delete' w s))) 418 | in match _tagMember n s , eqi n curtag with 419 | | left _ , right _ => maybe s go (peek s) 420 | | _ , _ => s 421 | end. 422 | 423 | Definition findDistance (w : a) (stk: stack) : option nat := 424 | match stk with 425 | | Stack ls t rs => elemIndex eqa w (t :: ls ++ rev rs) 426 | end. 427 | 428 | Definition _focusWindow : a -> stackSet -> stackSet := 429 | fun w s => 430 | match eqOption (Some w) (peek s) with 431 | | left p => s 432 | | right _ => 433 | let go := _findTag w s >>= fun n => 434 | withStack None (findDistance w) (_view n s) >>= fun d => 435 | Some (applyN d (_view n s) focusUp) 436 | in maybe s id go 437 | end. 438 | 439 | Definition onWorkspace (n : i) (f : stackSet -> stackSet) (s : stackSet) 440 | := _view (currentTag s) (f (_view n s)). 441 | 442 | Definition _shiftWin : i -> a -> stackSet -> stackSet := 443 | fun n w s => 444 | let go from x := onWorkspace n (_insertUp w) (onWorkspace from (_delete' w) x) 445 | in match _findTag w s with 446 | | None => s 447 | | Some from => 448 | match _tagMember n s , eqi n from with 449 | | left p , right q => go from s 450 | | _ , _ => s 451 | end 452 | end. 453 | 454 | End StackSet_defs. 455 | 456 | Definition mapLayout (a i l l' sd : Set) 457 | (f : l -> l') (s : stackSet i l a sd) : stackSet i l' a sd 458 | := match s with 459 | | StackSet v vs hs m => 460 | let fWorkspace := fun w => 461 | match w with 462 | | Workspace t x s => Workspace t (f x) s 463 | end 464 | in let fScreen s := 465 | match s with 466 | | Screen ws s sd => Screen (fWorkspace ws) s sd 467 | end in 468 | StackSet (fScreen v) (map fScreen vs) (map fWorkspace hs) m 469 | end. 470 | 471 | -------------------------------------------------------------------------------- /src/Properties.v: -------------------------------------------------------------------------------- 1 | Require Import Aux List. 2 | Require Import StackSet. 3 | Require Import Arith. 4 | Require Import Sorting.Permutation. 5 | Require Import ListLemmas. 6 | 7 | Variable (i l a b sd : Set). 8 | 9 | Definition invariant (i l a sd : Set) (s : StackSet.stackSet i l a sd) : Prop := 10 | let visibles := map (fun x => getWorkspace x) (getVisible s) in 11 | let hiddens := getHidden s in 12 | let current := getWorkspace (getCurrent s) in 13 | let findStack := fun x => maybe nil (fun s => s :: nil) (getStack x) in 14 | let getFocusUpDown := fun t => getFocus t :: getUp t ++ getDown t in 15 | let ts := flat_map findStack (current :: visibles ++ hiddens) in 16 | NoDup (flat_map getFocusUpDown ts). 17 | 18 | Implicit Arguments invariant. 19 | 20 | Theorem prop_empty_I (m : l) (wids : {wids : list i | wids <> nil}) 21 | (sds : {sds : list sd | length sds <= length (proj1_sig wids) /\ sds <> nil}) 22 | : invariant (new l m wids sds). 23 | Proof. 24 | destruct sds as [sds [sdsLength nonNil]]; simpl in sdsLength. 25 | induction sds as [ | sd sds]. 26 | (* Base case *) 27 | contradiction nonNil; auto. 28 | (* Cons case *) 29 | destruct wids as [wds widsProp]; induction wds as [ | wd wds]. 30 | (* Base case *) 31 | simpl in *; absurd (S (length sds) <= 0); auto with arith. 32 | (* Cons case *) 33 | unfold new, invariant. 34 | simpl in *. 35 | rewrite FlatMapApp. 36 | rewrite FlatMapApp. 37 | Admitted. 38 | 39 | Theorem prop_empty (m : l) (wids : {wids : list i | wids <> nil}) 40 | (sds : {sds : list sd | length sds <= length (proj1_sig wids) /\ sds <> nil}) 41 | (eq_a_dec : forall x y, {x = y} + {x <> y}): forall x, 42 | ~ (eq_true (StackSet._member eq_a_dec x (new l m wids sds))). 43 | Proof. 44 | intros x H. 45 | destruct wids as [[ | wid wids] NotNilWids]; 46 | [now (contradiction NotNilWids) | ]. 47 | destruct sds as [[ | sd sds] [SdsH1 SdsH2]]; 48 | [now (contradiction SdsH2) | ]. 49 | simpl in H. 50 | Admitted. 51 | 52 | Theorem prop_differentiate (xs : list a) : 53 | match xs with 54 | | nil => differentiate xs = None 55 | | x :: xs => differentiate (x :: xs) = Some (Stack nil x xs) 56 | end. 57 | destruct xs as [ | x xs]; reflexivity. 58 | Qed. 59 | 60 | Definition hidden_spaces (x : stackSet i l a sd) := map (fun s => getWorkspace s) (getVisible x) ++ getHidden x. 61 | 62 | Lemma modify'_getVisible (f : stack a -> stack a) (x : stackSet i l a sd) : 63 | getVisible (modify' f x) = getVisible x. 64 | Proof. 65 | destruct x; destruct getCurrent; destruct getWorkspace. 66 | reflexivity. 67 | Qed. 68 | 69 | Lemma modify'_getHidden (f : stack a -> stack a) (x : stackSet i l a sd) : 70 | getHidden (modify' f x) = getHidden x. 71 | Proof. 72 | destruct x; destruct getCurrent; destruct getWorkspace; reflexivity. 73 | Qed. 74 | 75 | Lemma modify'_hidden (f : stack a -> stack a) (x : stackSet i l a sd) : 76 | hidden_spaces (modify' f x) = hidden_spaces x. 77 | Proof. 78 | unfold hidden_spaces. 79 | rewrite (modify'_getHidden f). 80 | rewrite (modify'_getVisible f). 81 | reflexivity. 82 | Qed. 83 | 84 | Lemma modify_getHidden (d : option (stack a)) (f : stack a -> option (stack a)) (x : stackSet i l a sd) : 85 | getHidden (modify d f x) = getHidden x. 86 | Proof. 87 | destruct x; destruct getCurrent; destruct getWorkspace; reflexivity. 88 | Qed. 89 | 90 | Lemma modify_getVisible (d : option (stack a)) (f : stack a -> option (stack a)) (x : stackSet i l a sd) : 91 | getVisible (modify d f x) = getVisible x. 92 | Proof. 93 | destruct x; destruct getCurrent; destruct getWorkspace; reflexivity. 94 | Qed. 95 | 96 | 97 | Lemma modify_hidden (d : option (stack a)) (f : stack a -> option 98 | (stack a)) (x : stackSet i l a sd) : hidden_spaces (modify d f x) = 99 | hidden_spaces x. 100 | Proof. 101 | unfold hidden_spaces. rewrite (modify_getHidden d f). rewrite (modify_getVisible d f). 102 | reflexivity. Qed. 103 | 104 | Theorem prop_focus_down_local (s : stackSet i l a sd) : 105 | hidden_spaces (focusDown s) = hidden_spaces s. 106 | Proof. 107 | unfold focusDown; rewrite modify'_hidden; reflexivity. 108 | Qed. 109 | 110 | Theorem prop_focus_up_local (s : stackSet i l a sd) : 111 | hidden_spaces (focusUp s) = hidden_spaces s. 112 | Proof. 113 | unfold focusUp; rewrite modify'_hidden; reflexivity. 114 | Qed. 115 | 116 | Theorem prop_focus_master_local (s : stackSet i l a sd) : 117 | hidden_spaces (focusMaster s) = hidden_spaces s. 118 | Proof. 119 | unfold focusMaster; rewrite modify'_hidden; reflexivity. 120 | Qed. 121 | 122 | Lemma stackSet_eq (x y : stackSet i l a sd) : 123 | (getCurrent x = getCurrent y) -> 124 | (getVisible x = getVisible y) -> 125 | (getHidden x = getHidden y) -> 126 | (getFloating x = getFloating y) -> 127 | x = y. 128 | Proof. 129 | intros H1 H2 H3 H4. 130 | destruct x. simpl in *. 131 | rewrite H1, H2, H3, H4. 132 | destruct y; reflexivity. 133 | Qed. 134 | 135 | Lemma screen_eq (x y : screen i l a sd ) : 136 | (getWorkspace x = getWorkspace y) -> 137 | (getScreen x = getScreen y) -> 138 | (getScreenDetail x = getScreenDetail y) -> 139 | x = y. 140 | Proof. 141 | intros H1 H2 H3; destruct x; simpl in *; rewrite H1, H2, H3; destruct y; reflexivity. 142 | Qed. 143 | 144 | Lemma workspace_eq (x y : workspace i l a) : 145 | (getTag x = getTag y) -> 146 | (getLayout x = getLayout y) -> 147 | (getStack x = getStack y) -> 148 | x = y. 149 | Proof. 150 | intros H1 H2 H3; destruct x; simpl in *; rewrite H1, H2, H3; destruct y; reflexivity. 151 | Qed. 152 | 153 | Theorem prop_delete_local (s : stackSet i l a sd) (eq_dec : forall x y, {x = y} + {x <> y}) : 154 | match peek s with 155 | | None => True 156 | | Some i => hidden_spaces s = hidden_spaces (_delete eq_dec i s) 157 | end. 158 | Proof. 159 | remember (peek s). 160 | destruct o as [x | ]; [ | trivial]. 161 | unfold _delete. 162 | unfold sink. 163 | unfold _delete'. 164 | destruct s. 165 | destruct getCurrent. 166 | f_equal. 167 | destruct getWorkspace. 168 | apply stackSet_eq. 169 | simpl in *. 170 | apply screen_eq. 171 | simpl. 172 | apply workspace_eq; try reflexivity. 173 | destruct getStack. 174 | unfold peek in Heqo. 175 | unfold withStack in Heqo. 176 | simpl in *. 177 | unfold filterStack. 178 | unfold getFocus in Heqo. 179 | destruct s. 180 | injection Heqo. 181 | intros Eq. 182 | rewrite <- Eq in *. 183 | simpl. 184 | assert (negb (proj1_sig (beqa eq_dec x x)) = false). 185 | generalize (beqa eq_dec x x). 186 | destruct s. 187 | Admitted. 188 | 189 | Theorem prop_swap_master_local (s : stackSet i l a sd) : 190 | hidden_spaces s = hidden_spaces (swapMaster s). 191 | Proof. 192 | unfold swapMaster; rewrite modify'_hidden; reflexivity. 193 | Qed. 194 | 195 | Theorem prop_swap_left_local (s : stackSet i l a sd) : 196 | hidden_spaces s = hidden_spaces (swapUp s). 197 | Proof. 198 | unfold swapUp; rewrite modify'_hidden; reflexivity. 199 | Qed. 200 | 201 | Theorem prop_swap_right_local (s : stackSet i l a sd) : 202 | hidden_spaces s = hidden_spaces (swapDown s). 203 | Proof. 204 | unfold swapDown; rewrite modify'_hidden; reflexivity. 205 | Qed. 206 | 207 | Theorem prop_shift_master_local (s : stackSet i l a sd) : 208 | hidden_spaces s = hidden_spaces (shiftMaster s). 209 | Proof. 210 | unfold shiftMaster; rewrite modify'_hidden; reflexivity. 211 | Qed. 212 | 213 | Lemma focusUpDown' (s : stack a) : 214 | focusDown' (focusUp' s) = s. 215 | Proof. 216 | destruct s as [[ | l ls] c rs]; try reflexivity. 217 | unfold StackSet.focusUp'; simpl. 218 | assert (H : rev (rev rs) = rs); try apply rev_involutive. 219 | generalize (rev rs) as rrs, H. 220 | destruct rrs as [ | r rrs]. 221 | (* Base case *) 222 | intro Eq; rewrite <- Eq; reflexivity. 223 | (* Inductive case *) 224 | unfold StackSet.focusDown'; simpl. 225 | intro Eq; rewrite rev_unit, <- Eq; reflexivity. 226 | Qed. 227 | 228 | Lemma focusDownUp' (s : StackSet.stack a) : 229 | StackSet.focusUp' (StackSet.focusDown' s) = s. 230 | Proof. 231 | destruct s as [ls c [ | r rs]]; unfold StackSet.focusDown'; try reflexivity. 232 | simpl; f_equal. 233 | (* Proof that getUp is OK *) 234 | assert (H : rev ls = rev ls); auto. 235 | generalize H as Eq. 236 | generalize (rev ls) at 1 3 4 as rls. 237 | intros. 238 | destruct rls as [ | x xs]. 239 | simpl; symmetry; apply revNil; rewrite Eq; reflexivity. 240 | simpl; rewrite rev_unit; simpl; rewrite revStep, Eq, rev_involutive; reflexivity. 241 | (* Proof that getFocus is OK *) 242 | destruct (rev ls) as [ | z zs]; simpl; try rewrite rev_unit; reflexivity. 243 | Qed. 244 | 245 | Lemma modifyId (f : StackSet.stack a -> StackSet.stack a) (s : StackSet.stackSet i l a sd) : 246 | (forall xs, f xs = xs) -> StackSet.modify' f s = s. 247 | Proof. 248 | intro H; destruct s. 249 | unfold StackSet.modify', StackSet.modify. 250 | destruct getCurrent; destruct getWorkspace; destruct getStack; repeat (f_equal). 251 | unfold StackSet.withStack. 252 | simpl; f_equal; apply H; reflexivity. 253 | Qed. 254 | 255 | Lemma modifyComp (f g : StackSet.stack a -> StackSet.stack a) (s : StackSet.stackSet i l a sd) : 256 | StackSet.modify' f (StackSet.modify' g s) = StackSet.modify' (fun s => f (g s)) s. 257 | Proof. 258 | destruct s; unfold StackSet.modify', StackSet.modify. 259 | destruct getCurrent; destruct getWorkspace; destruct getStack; repeat (f_equal). 260 | Qed. 261 | 262 | Theorem prop_focus_right (s : StackSet.stackSet i l a sd) : 263 | StackSet.focusDown (StackSet.focusUp s) = s. 264 | Proof. 265 | unfold StackSet.focusUp, StackSet.focusDown. 266 | rewrite modifyComp, modifyId; [ | intros; rewrite focusUpDown']; reflexivity. 267 | Qed. 268 | 269 | Theorem prop_focus_left (s : StackSet.stackSet i l a sd) : 270 | StackSet.focusUp (StackSet.focusDown s) = s. 271 | Proof. 272 | unfold StackSet.focusUp, StackSet.focusDown. 273 | rewrite modifyComp, modifyId; auto; intros; rewrite focusDownUp'; reflexivity. 274 | Qed. 275 | 276 | Theorem prop_swap_master_focus (x : StackSet.stackSet i l a sd) : 277 | StackSet.peek (StackSet.swapMaster x) = StackSet.peek x. 278 | Proof. 279 | destruct x; unfold StackSet.peek; unfold StackSet.swapMaster; unfold StackSet.modify'. 280 | destruct getCurrent; destruct getWorkspace. 281 | unfold StackSet.withStack; unfold StackSet.getFocus. 282 | destruct getStack; simpl; [ destruct s; destruct getUp | ] ; reflexivity. 283 | Qed. 284 | 285 | Theorem prop_swap_left_focus (x : StackSet.stackSet i l a sd) : 286 | StackSet.peek (StackSet.swapUp x) = StackSet.peek x. 287 | Proof. 288 | destruct x; unfold StackSet.peek; unfold StackSet.swapUp; unfold StackSet.modify'. 289 | destruct getCurrent; destruct getWorkspace. 290 | unfold StackSet.withStack; unfold StackSet.getFocus. 291 | destruct getStack; simpl; [destruct s; destruct getUp | ]; reflexivity. 292 | Qed. 293 | 294 | Theorem prop_swap_right_focus (x : StackSet.stackSet i l a sd) : 295 | StackSet.peek (StackSet.swapDown x) = StackSet.peek x. 296 | Proof. 297 | destruct x; unfold StackSet.peek; unfold StackSet.swapDown; unfold StackSet.modify'. 298 | destruct getCurrent; destruct getWorkspace. 299 | unfold StackSet.withStack; unfold StackSet.getFocus; unfold StackSet.reverseStack. 300 | destruct getStack; simpl; [destruct s; destruct getDown | ]; simpl; reflexivity. 301 | Qed. 302 | 303 | Theorem prop_swap_master_idempotent (x : StackSet.stackSet i l a sd) : 304 | StackSet.swapMaster (StackSet.swapMaster x) = StackSet.swapMaster x. 305 | Proof. 306 | destruct x; unfold StackSet.swapMaster, StackSet.modify'. 307 | destruct getCurrent; destruct getWorkspace. 308 | destruct getStack as [ stack | ]; [ | reflexivity ]. 309 | destruct stack as [ls c rs]; simpl. 310 | unfold StackSet.withStack; simpl. 311 | repeat f_equal. 312 | destruct ls; auto. 313 | Qed. 314 | 315 | 316 | Theorem prop_screens_work (x : stackSet i l a sd) : 317 | screens x = getCurrent x :: getVisible x. 318 | Proof. 319 | destruct x; unfold screens; reflexivity. 320 | Qed. 321 | 322 | Theorem prop_mapWorkspaceId (x : stackSet i l a sd) : 323 | mapWorkspace (fun y => y) x = x. 324 | Proof. 325 | unfold mapWorkspace. 326 | destruct x. 327 | destruct getCurrent. 328 | rewrite map_id. 329 | replace (map (fun scr => match scr with 330 | | {| getWorkspace := w; getScreen := s; getScreenDetail := sd0 |} => 331 | {| getWorkspace := w; getScreen := s; getScreenDetail := sd0 |} 332 | end) 333 | getVisible) 334 | with getVisible. 335 | reflexivity. 336 | induction getVisible; [ reflexivity | ]. 337 | simpl; rewrite <- IHgetVisible; destruct a0; reflexivity. 338 | Qed. 339 | 340 | Require Import Coq.Program.Equality. 341 | 342 | Theorem prop_focusMaster_idem (x : StackSet.stackSet i l a sd) : 343 | StackSet.focusMaster (StackSet.focusMaster x) = StackSet.focusMaster x. 344 | Proof. 345 | destruct x. 346 | unfold StackSet.focusMaster. 347 | unfold modify', modify, withStack. 348 | simpl. 349 | destruct getCurrent; destruct getWorkspace; destruct getStack; try reflexivity. 350 | destruct s as [ls c rs]. 351 | apply stackSet_eq; try reflexivity. 352 | apply screen_eq; try reflexivity. 353 | apply workspace_eq; try reflexivity. 354 | simpl. 355 | destruct ls; try reflexivity. 356 | (* destruct (rev ls ++ a0 :: nil). *) 357 | Admitted. 358 | 359 | Fixpoint concat (a : Set) (xss : list (list a)) : list a := 360 | match xss with 361 | | nil => nil 362 | | xs :: xss => xs ++ concat a xss 363 | end. 364 | 365 | Lemma PermutationRotate (xs : list a) : Permutation xs (rotate xs). 366 | induction xs; [constructor | ]. 367 | apply Permutation_cons_app; rewrite app_nil_r; auto. 368 | Qed. 369 | 370 | 371 | Theorem prop_insert_local (x : stackSet i l a sd) (eq_dec : forall x y, {x = y} + {x <> y}) : 372 | forall i, ~(eq_true (_member eq_dec i x)) -> hidden_spaces x = hidden_spaces (_insertUp eq_dec i x). 373 | Proof. 374 | intros y H. 375 | unfold _insertUp. 376 | destruct (_member eq_dec y x). 377 | reflexivity. 378 | rewrite modify_hidden. 379 | reflexivity. 380 | Qed. 381 | 382 | Theorem prop_swap_master_I (s : StackSet.stackSet i l a sd) : 383 | invariant s -> invariant (swapMaster s). 384 | Proof. 385 | intro H; destruct s; destruct getCurrent; destruct getWorkspace; simpl. 386 | destruct getStack as [ | s]; auto. 387 | destruct s as [ls c rs]; auto. 388 | destruct ls as [ | l ls]; auto. 389 | unfold withStack; unfold invariant in *. 390 | apply (NoDupPerm _ _ _ H); clear H. 391 | simpl; constructor. 392 | do 2 (rewrite app_comm_cons; apply Permutation_app_tail). 393 | apply (Permutation_trans (l' := (rev ls ++ l :: nil))); 394 | [ apply Permutation_rev | apply PermutationRotate]. 395 | Qed. 396 | 397 | Theorem prop_view_I (l a sd : Set) (n : nat) (s : StackSet.stackSet nat l a sd) : 398 | invariant s -> invariant (_view eq_nat_dec n s). 399 | Proof. 400 | unfold _view. 401 | case (eq_nat_dec n (currentTag s)); auto. 402 | case (find (fun y => proj1_sig (beqi eq_nat_dec n (getTag (getWorkspace y)))) 403 | (getVisible s)). 404 | destruct s. 405 | intros s H1 H2. 406 | Admitted. 407 | 408 | Lemma invariant_lemma : forall (i l a sd : Set) (v v' : list (screen i l a sd)) (h h' : list (workspace i l a)) c f, 409 | Permutation v v' -> 410 | Permutation h h' -> 411 | invariant (StackSet c v h f) -> 412 | invariant (StackSet c v' h' f). 413 | Proof. 414 | intros i l a sd v v' h h' c f Pv Ph. 415 | unfold invariant. 416 | intros I. apply (NoDupPerm _ _ _ I). 417 | simpl in *. 418 | apply PermutationFlatMap. 419 | apply Permutation_app. 420 | apply Permutation_refl. 421 | apply PermutationFlatMap. 422 | apply Permutation_app. 423 | apply Permutation_map. 424 | assumption. 425 | assumption. 426 | Qed. 427 | Theorem prop_greedyView_I (l a sd : Set) (n : nat) (s : StackSet.stackSet nat l a sd) : 428 | invariant s -> invariant (_greedyView eq_nat_dec n s). 429 | Proof. 430 | unfold _greedyView. 431 | destruct (existsb (fun x => proj1_sig (beqi eq_nat_dec n (getTag x))) (getHidden s)). 432 | apply prop_view_I. 433 | destruct (find (fun x => proj1_sig 434 | (beqi eq_nat_dec n (getTag (getWorkspace x)))) 435 | (getVisible s)); auto. 436 | destruct s. destruct s0. 437 | apply invariant_lemma; try apply Permutation_refl. 438 | simpl. 439 | Admitted. 440 | 441 | Theorem prop_focusUp_I (l a sd : Set) (n : nat) (s : StackSet.stackSet nat l a sd) : 442 | invariant s -> invariant (iterate n (focusUp (i:=nat) (l:=l) (a:=a)(sd:=sd)) s). 443 | Proof. 444 | generalize s; induction n; auto; clear s. 445 | intros s IHs; simpl. 446 | cut (invariant (focusUp s)). 447 | intro H; apply (IHn _ H). 448 | unfold invariant in *; simpl in *. 449 | rewrite FlatMapApp. 450 | apply (NoDupPerm _ _ _ IHs). 451 | rewrite FlatMapApp in *. 452 | apply (Permutation_app). 453 | destruct s. 454 | destruct getCurrent. 455 | destruct getWorkspace. 456 | destruct getStack. 457 | simpl. 458 | unfold focusUp'. 459 | destruct s. 460 | destruct getUp. 461 | simpl. 462 | repeat rewrite (app_nil_r). 463 | destruct getDown. 464 | apply (Permutation_refl). 465 | simpl. 466 | Focus 2. 467 | repeat rewrite (app_nil_r). 468 | simpl. 469 | apply (Permutation_trans (l' := a0 :: getFocus :: getUp ++ getDown)). 470 | constructor. 471 | constructor. 472 | apply (Permutation_cons_app). 473 | apply Permutation_refl. 474 | simpl. 475 | replace (hd getFocus (rev getDown ++ a0 :: nil) 476 | :: tl ((rev getDown ++ a0 :: nil) ++ getFocus :: nil)) 477 | with 478 | (((hd getFocus (rev getDown ++ a0 :: nil) 479 | :: tl ((rev getDown ++ a0 :: nil))) ++ getFocus :: nil)). 480 | rewrite HdTlNotNil. 481 | apply Permutation_cons_app. 482 | rewrite app_nil_r. 483 | apply Permutation_cons_app. 484 | rewrite app_nil_r. 485 | apply Permutation_rev. 486 | destruct getDown. 487 | intros F; discriminate F. 488 | intros F. 489 | refine (app_cons_not_nil (rev (a1 :: getDown)) nil a0 _). 490 | symmetry; assumption. 491 | simpl. f_equal. 492 | destruct (rev getDown); reflexivity. 493 | simpl; constructor. 494 | apply PermutationFlatMap. 495 | apply PermutationFlatMap. 496 | apply Permutation_app. 497 | apply Permutation_map. 498 | destruct s; destruct getVisible; destruct getCurrent; destruct getWorkspace. 499 | constructor. 500 | apply Permutation_refl. 501 | destruct s; destruct getVisible; destruct getCurrent; destruct getWorkspace. 502 | apply Permutation_refl. 503 | apply Permutation_refl. 504 | Qed. 505 | 506 | Theorem prop_focusDown_I (l a sd : Set) (n : nat) (s : StackSet.stackSet nat l a sd) : 507 | invariant s -> invariant (iterate n (focusDown (i:=nat) (l:=l) (a:=a)(sd:=sd)) s). 508 | Proof. 509 | generalize s; induction n; auto; clear s. 510 | intros s IHs; simpl. 511 | cut (invariant (focusDown s)). 512 | intro H; apply (IHn _ H). 513 | unfold invariant in *; simpl in *. 514 | rewrite FlatMapApp. 515 | apply (NoDupPerm _ _ _ IHs). 516 | rewrite FlatMapApp in *. 517 | apply (Permutation_app). 518 | destruct s; destruct getCurrent; destruct getWorkspace; destruct getStack. 519 | simpl. 520 | unfold focusDown', focusUp'. 521 | destruct s. 522 | destruct getUp. 523 | simpl. 524 | repeat rewrite (app_nil_r). 525 | destruct getDown. 526 | apply (Permutation_refl). 527 | simpl. 528 | constructor. 529 | repeat rewrite (app_nil_r). 530 | simpl. 531 | apply (Permutation_trans (l' := a0 :: getFocus :: getUp ++ getDown)). 532 | constructor. 533 | destruct getDown. 534 | simpl. 535 | replace (hd getFocus (rev getUp ++ a0 :: nil) 536 | :: tl ((rev getUp ++ a0 :: nil) ++ getFocus :: nil)) 537 | with 538 | (((hd getFocus (rev getUp ++ a0 :: nil) 539 | :: tl ((rev getUp ++ a0 :: nil))) ++ getFocus :: nil)). 540 | rewrite HdTlNotNil. 541 | rewrite app_nil_r. 542 | rewrite <- app_assoc. 543 | simpl. 544 | apply Permutation_cons_app. 545 | apply Permutation_cons_app. 546 | rewrite app_nil_r. 547 | apply Permutation_rev. 548 | destruct getUp. 549 | intros F; discriminate F. 550 | intros F. 551 | refine (app_cons_not_nil (rev (a1 :: getUp)) nil a0 _). 552 | symmetry; assumption. 553 | simpl. f_equal. 554 | destruct (rev getUp); reflexivity. 555 | simpl. 556 | replace (a0 :: getFocus :: getUp ++ a1 :: getDown) with 557 | ((a0 :: getFocus :: getUp ++ a1 :: nil) ++ getDown). 558 | replace (a1 :: getFocus :: a0 :: getUp ++ getDown) with 559 | ((a1 :: getFocus :: a0 :: getUp) ++ getDown). 560 | apply Permutation_app_tail. 561 | replace (a1 :: getFocus :: a0 :: getUp) with 562 | ((a1 :: getFocus :: nil) ++ a0 :: getUp). 563 | apply Permutation_cons_app. 564 | simpl. 565 | apply Permutation_sym. 566 | replace (getFocus :: getUp ++ a1 :: nil) with 567 | ((getFocus :: getUp) ++ (a1 :: nil)). 568 | apply Permutation_cons_app. 569 | rewrite app_nil_r. 570 | apply Permutation_refl. 571 | reflexivity. 572 | reflexivity. 573 | reflexivity. 574 | simpl. 575 | f_equal. 576 | f_equal. 577 | rewrite <- app_assoc. 578 | reflexivity. 579 | constructor. 580 | apply PermutationFlatMap, PermutationFlatMap. 581 | apply Permutation_app. 582 | apply Permutation_map. 583 | destruct s; destruct getVisible; destruct getCurrent; destruct getWorkspace. 584 | constructor. 585 | apply Permutation_refl. 586 | destruct s; destruct getVisible; destruct getCurrent; destruct getWorkspace. 587 | apply Permutation_refl. 588 | apply Permutation_refl. 589 | Qed. 590 | 591 | 592 | Theorem prop_focusMaster_I (l a sd : Set) (n : nat) (s : StackSet.stackSet nat l a sd) : 593 | invariant s -> invariant (iterate n (focusMaster (i:=nat) (l:=l) (a:=a)(sd:=sd)) s). 594 | Proof. 595 | generalize s; induction n; auto. 596 | intros st IHs; simpl. 597 | cut (invariant (focusMaster st)). 598 | intro H; apply (IHn _ H). 599 | unfold invariant in *; simpl in *. 600 | 601 | rewrite FlatMapApp in *. 602 | apply (NoDupPerm _ _ _ IHs). 603 | apply (Permutation_app). 604 | destruct st. 605 | destruct getCurrent. 606 | destruct getWorkspace. 607 | destruct getStack. 608 | simpl. 609 | destruct s0. 610 | destruct getUp. 611 | constructor. 612 | apply (Permutation_refl). 613 | Admitted. 614 | 615 | Ltac destruct_stackset x := destruct x; destruct getCurrent; destruct getWorkspace; destruct getStack. 616 | 617 | Theorem prop_mapLayoutId (s : stackSet i l a sd) : 618 | mapLayout (fun x => x) s = s. 619 | Proof. 620 | destruct s; destruct getCurrent; destruct getWorkspace. 621 | apply stackSet_eq; try reflexivity. 622 | induction getVisible. 623 | reflexivity. 624 | simpl in *. 625 | destruct a0. 626 | destruct getWorkspace. 627 | rewrite IHgetVisible. 628 | reflexivity. 629 | simpl. 630 | induction getHidden; try reflexivity. 631 | simpl; rewrite IHgetHidden; destruct a0; reflexivity. 632 | Qed. 633 | 634 | Theorem prop_mapLayoutInverse (s : stackSet i nat a sd) : 635 | mapLayout pred (mapLayout S s) = s. 636 | Proof. 637 | destruct s. 638 | simpl. 639 | f_equal. 640 | destruct getCurrent. 641 | f_equal. 642 | destruct getWorkspace. 643 | reflexivity. 644 | induction getVisible. 645 | reflexivity. 646 | destruct a0. 647 | simpl. 648 | rewrite IHgetVisible. 649 | destruct getWorkspace. 650 | reflexivity. 651 | induction getHidden; try reflexivity. 652 | destruct a0; simpl; rewrite IHgetHidden; reflexivity. 653 | Qed. 654 | 655 | Definition predTag (w : workspace nat l a) : workspace nat l a := 656 | match w with 657 | | Workspace t l s => Workspace (pred t) l s 658 | end. 659 | 660 | Definition succTag (w : workspace nat l a) : workspace nat l a := 661 | match w with 662 | | Workspace t l s => Workspace (S t) l s 663 | end. 664 | 665 | Theorem prop_mapWorkspaceInverse (s : stackSet nat l a sd) : 666 | mapWorkspace predTag (mapWorkspace succTag s) = s. 667 | Proof. 668 | destruct s; destruct getCurrent; destruct getWorkspace. 669 | unfold mapWorkspace. 670 | f_equal. 671 | induction getVisible; try reflexivity. 672 | simpl; destruct a0; rewrite IHgetVisible; unfold predTag; unfold succTag; simpl. 673 | destruct getWorkspace. reflexivity. 674 | induction getHidden; try reflexivity. 675 | destruct a0. 676 | simpl. rewrite IHgetHidden. 677 | reflexivity. 678 | Qed. 679 | 680 | Theorem prop_screens (s : stackSet i l a sd) : 681 | In (getCurrent s) (screens s). 682 | Proof. 683 | destruct s. 684 | destruct getCurrent; left; reflexivity. 685 | Qed. 686 | 687 | Theorem prop_lookup_current (x : stackSet i l a sd) : 688 | lookupWorkspace (getScreen (getCurrent x)) x = Some (getTag (getWorkspace (getCurrent x))). 689 | Proof. 690 | destruct x. 691 | destruct getCurrent. 692 | simpl. 693 | unfold lookupWorkspace. 694 | simpl. 695 | destruct (beqsid getScreen getScreen) as [b T]. 696 | destruct b. 697 | reflexivity. 698 | exfalso; apply T; reflexivity. 699 | Qed. 700 | 701 | Theorem prop_lookup_visible (x : stackSet i l a sd) : 702 | getVisible x <> nil -> 703 | (forall (x y : screen i l a sd), getScreen x = getScreen y -> x = y) -> (* the StackSet invariant *) 704 | match last (map (fun x => Some (getScreen x)) (getVisible x)) None with 705 | | None => True 706 | | Some sc => 707 | In (lookupWorkspace sc x) (map (fun x => Some (getTag (getWorkspace x))) (getVisible x)) 708 | end. 709 | Proof. 710 | remember (last (map (fun x => Some (getScreen x)) (getVisible x)) None). 711 | destruct y; try trivial. 712 | intros F; induction getVisible as [ | y ys]. 713 | exfalso; apply F; reflexivity. 714 | induction ys as [ | z zs]. 715 | left. 716 | destruct x. 717 | unfold lookupWorkspace. 718 | simpl. 719 | injection Heqy. 720 | intros Eq. 721 | rewrite Eq. 722 | destruct (beqsid (getScreen y) (getScreen getCurrent)) as [b B]. 723 | destruct b; simpl in *. 724 | rewrite (H _ _ B). 725 | destruct getCurrent; reflexivity. 726 | Focus 2. 727 | intros H. 728 | right. 729 | apply IHys. 730 | assumption. 731 | discriminate. 732 | assumption. 733 | destruct y. 734 | simpl in *. 735 | destruct getCurrent. 736 | simpl in *. 737 | Admitted. 738 | 739 | 740 | --------------------------------------------------------------------------------