liboleg (empty) → 0.1
raw patch · 6 files changed
+599/−0 lines, 6 filesdep +basedep +containerssetup-changed
Dependencies added: base, containers
Files
- Data/FDList.hs +254/−0
- LICENSE +30/−0
- Setup.lhs +3/−0
- Text/PrintScan.hs +137/−0
- Text/PrintScanF.hs +145/−0
- liboleg.cabal +30/−0
+ Data/FDList.hs view
@@ -0,0 +1,254 @@+-- | Haskell98+--+-- <http://okmij.org/ftp/Algorithms.html#pure-cyclic-list>+--+-- Pure functional, mutation-free, constant-time-access double-linked+-- lists+--+-- Note that insertions, deletions, lookups have+-- a worst-case complexity of O(min(n,W)), where W is either 32 or 64+-- (depending on the paltform). That means the access time is bounded+-- by a small constant (32 or 64). +--+--+-- /Pure functional, mutation-free, efficient double-linked lists/+-- +-- It is always an interesting challenge to write a pure functional and efficient implementation of+-- an imperative algorithm destructively operating a data structure. The functional implementation+-- has a significant benefit of equational reasoning and modularity. We can comprehend the algorithm+-- without keeping the implicit global state in mind. The mutation-free, functional realization has+-- practical benefits: the ease of adding checkpointing, undo and redo. The absence of mutations+-- makes the code multi-threading-safe and helps in porting to distributed or non-shared-memory+-- parallel architectures. On the other hand, an imperative implementation has the advantage of+-- optimality: mutating a component in a complex data structure is a constant-time operation, at+-- least on conventional architectures. Imperative code makes sharing explicit, and so permits+-- efficient implementation of cyclic data structures.+-- +-- We show a simple example of achieving all the benefits of an imperative data structure --+-- including sharing and the efficiency of updates -- in a pure functional program. Our data+-- structure is a doubly-linked, possibly cyclic list, with the standard operations of adding,+-- deleting and updating elements; traversing the list in both directions; iterating over the list,+-- with cycle detection. The code:+-- +-- □ uniformly handles both cyclic and terminated lists;+-- □ does not rebuild the whole list on updates;+-- □ updates the value in the current node in time bound by a small constant;+-- □ does not use or mention any monads;+-- □ does not use any IORef, STRef, TVars, or any other destructive updates;+-- □ permits the logging, undoing and redoing of updates, checkpointing;+-- □ easily generalizes to two-dimensional meshes.+-- +-- The algorithm is essentially imperative, thus permitting identity checking and in-place+-- `updates', but implemented purely functionally. Although the code uses many local, type safe+-- `heaps', there is emphatically no global heap and no global state.+-- +-- Version: The current version is 1.2, Jan 7, 2009.+--+-- References+--+-- Haskell-Cafe discussion ``Updating doubly linked lists''. January 2009+--+module Data.FDList where++import qualified Data.IntMap as IM++-- | Representation of the double-linked list+type Ref = Int -- positive, we shall treat 0 specially++data Node a = Node{node_val :: a,+ node_left :: Ref,+ node_right :: Ref}++-- | Because DList contains the `pointer' to the current element, DList+-- is also a Zipper+data DList a = DList{dl_counter :: Ref, -- to generate new Refs+ dl_current :: Ref, -- current node+ dl_mem :: IM.IntMap (Node a)} -- main `memory'+++-- | Operations on the DList a+empty :: DList a+empty = DList{dl_counter = 1, dl_current = 0, dl_mem = IM.empty}++-- | In a well-formed list, dl_current must point to a valid node+-- All operations below preserve well-formedness+well_formed :: DList a -> Bool+well_formed dl | IM.null (dl_mem dl) = dl_current dl == 0+well_formed dl = IM.member (dl_current dl) (dl_mem dl)++is_empty :: DList a -> Bool+is_empty dl = IM.null (dl_mem dl)+++-- | auxiliary function+get_curr_node :: DList a -> Node a+get_curr_node DList{dl_current=curr,dl_mem=mem} = + maybe (error "not well-formed") id $ IM.lookup curr mem++-- | The insert operation below makes a cyclic list+-- The other operations don't care+-- Insert to the right of the current element, if any+-- Return the DL where the inserted node is the current one+insert_right :: a -> DList a -> DList a+insert_right x dl | is_empty dl =+ let ref = dl_counter dl+ -- the following makes the list cyclic+ node = Node{node_val = x, node_left = ref, node_right = ref}+ in DList{dl_counter = succ ref,+ dl_current = ref,+ dl_mem = IM.insert ref node (dl_mem dl)}++insert_right x dl@DList{dl_counter = ref, dl_current = curr, dl_mem = mem} =+ DList{dl_counter = succ ref, dl_current = ref, + dl_mem = IM.insert ref new_node $ + IM.insert next next_node' $+ (if next == curr then mem else IM.insert curr curr_node' mem)}+ where+ curr_node = get_curr_node dl+ curr_node'= curr_node{node_right = ref}+ next = node_right curr_node+ next_node = if next == curr then curr_node'+ else maybe (error "ill-formed DList") id $ IM.lookup next mem+ new_node = Node{node_val = x, node_left = curr, node_right = next}+ next_node'= next_node{node_left = ref}+ ++-- | Delete the current element from a non-empty list+-- We can handle both cyclic and terminated lists+-- The right node becomes the current node.+-- If the right node does not exists, the left node becomes current+delete :: DList a -> DList a+delete dl@DList{dl_current = curr, dl_mem = mem_old} =+ case () of+ _ | notexist l && notexist r -> empty+ _ | r == 0 ->+ dl{dl_current = l, dl_mem = upd l (\x -> x{node_right=r}) mem}+ _ | r == curr -> -- it was a cycle on the right+ dl{dl_current = l, dl_mem = upd l (\x -> x{node_right=l}) mem}+ _ | l == 0 ->+ dl{dl_current = r, dl_mem = upd r (\x -> x{node_left=l}) mem}+ _ | l == curr ->+ dl{dl_current = r, dl_mem = upd r (\x -> x{node_left=r}) mem}+ _ | l == r ->+ dl{dl_current = r, dl_mem = upd r (\x -> x{node_left=r, + node_right=r}) mem}+ _ ->+ dl{dl_current = r, dl_mem = upd r (\x -> x{node_left=l}) .+ upd l (\x -> x{node_right=r}) $ mem}+ where+ (Just curr_node, mem) = IM.updateLookupWithKey (\_ _ -> Nothing) curr mem_old+ l = node_left curr_node+ r = node_right curr_node+ notexist x = x == 0 || x == curr+ upd ref f mem = IM.adjust f ref mem+++get_curr :: DList a -> a+get_curr = node_val . get_curr_node++move_right :: DList a -> Maybe (DList a)+move_right dl = if next == 0 then Nothing else Just (dl{dl_current=next})+ where+ next = node_right $ get_curr_node dl++-- | If no right, just stay inplace+move_right' :: DList a -> DList a+move_right' dl = maybe dl id $ move_right dl++move_left :: DList a -> Maybe (DList a)+move_left dl = if next == 0 then Nothing else Just (dl{dl_current=next})+ where+ next = node_left $ get_curr_node dl++-- | If no left, just stay inplace+move_left' :: DList a -> DList a+move_left' dl = maybe dl id $ move_left dl++fromList :: [a] -> DList a+fromList = foldl (flip insert_right) empty++-- | The following does not anticipate cycles (deliberately)+takeDL :: Int -> DList a -> [a]+takeDL 0 _ = []+takeDL n dl | is_empty dl = []+takeDL n dl = get_curr dl : (maybe [] (takeDL (pred n)) $ move_right dl)++-- | Reverse taking: we move left+takeDLrev :: Int -> DList a -> [a]+takeDLrev 0 _ = []+takeDLrev n dl | is_empty dl = []+takeDLrev n dl = get_curr dl : (maybe [] (takeDLrev (pred n)) $ move_left dl)++-- | Update the current node `inplace'+update :: a -> DList a -> DList a+update x dl@(DList{dl_current = curr, dl_mem = mem}) = + dl{dl_mem = IM.insert curr (curr_node{node_val = x}) mem}+ where+ curr_node = get_curr_node dl+++-- | This one watches for a cycle and terminates when it detects one+toList :: DList a -> [a]+toList dl | is_empty dl = []+toList dl = get_curr dl : collect (dl_current dl) (move_right dl)+ where+ collect ref0 Nothing = []+ collect ref0 (Just DList{dl_current = curr}) | curr == ref0 = []+ collect ref0 (Just dl) = get_curr dl : collect ref0 (move_right dl)++++-- Tests++test1l = insert_right 1 $ empty+test1l_r = takeDL 5 test1l -- [1,1,1,1,1]+test1l_l = takeDLrev 5 test1l -- [1,1,1,1,1]+test1l_c = toList test1l -- [1]++test2l = insert_right 2 $ test1l+test2l_r = takeDL 5 test2l -- [2,1,2,1,2]+test2l_l = takeDLrev 5 test2l -- [2,1,2,1,2]+test2l_l'= takeDLrev 5 (move_left' test2l) -- [1,2,1,2,1]+test2l_c = toList test2l -- [2,1]++test3l = insert_right 3 $ test2l+test3l_r = takeDL 7 test3l -- [3,1,2,3,1,2,3]+test3l_l = takeDLrev 7 test3l -- [3,2,1,3,2,1,3]+test3l_l'= takeDLrev 7 (move_left' test3l) -- [2,1,3,2,1,3,2]+test3l_c = toList (move_right' test3l) -- [1,2,3]+++test31l = delete test3l+test31l_r = takeDL 7 test31l -- [1,2,1,2,1,2,1]+test31l_l = takeDLrev 7 test31l -- [1,2,1,2,1,2,1]+test31l_c = toList test31l -- [1,2]++test32l = delete test31l+test32l_r = takeDL 5 test32l -- [2,2,2,2,2]+test32l_l = takeDLrev 5 test32l -- [2,2,2,2,2]+test32l_c = toList test32l -- [2]+++test33l = delete test32l+test33l_r = takeDL 5 test33l -- []+++testl = fromList [1..5]+testl_r = takeDL 11 testl -- [5,1,2,3,4,5,1,2,3,4,5]+testl_l = takeDLrev 11 testl -- [5,4,3,2,1,5,4,3,2,1,5]+testl_c = toList testl -- [5,1,2,3,4]++testl1 = update (-1) testl+testl1_r = takeDL 11 testl1 -- [-1,1,2,3,4,-1,1,2,3,4,-1]+testl1_c = toList testl1 -- [-1,1,2,3,4]++testl2 = update (-2) . move_right' . move_right' $ testl1+testl2_r = takeDL 11 testl2 -- [-2,3,4,-1,1,-2,3,4,-1,1,-2]+testl2_l = takeDLrev 11 testl2 -- [-2,1,-1,4,3,-2,1,-1,4,3,-2]+testl2_c = toList testl2 -- [-2,3,4,-1,1]++-- | Old testl is still available: there are no destructive updates+testl3 = update (-2) . move_right' . move_right' $ testl+testl3_r = takeDL 11 testl3 -- [-2,3,4,5,1,-2,3,4,5,1,-2]+testl3_c = toList testl3 -- [-2,3,4,5,1]+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2008 Oleg Kiselyov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Text/PrintScan.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE GADTs #-}++-- |+--+-- <http://okmij.org/ftp/typed-formatting/FPrintScan.html>+--+-- The initial view to the typed sprintf and sscanf+-- This code defines a simple domain-specific language of string+-- patterns and demonstrates two interpreters of the language:+-- for building strings (sprintf) and parsing strings (sscanf).+-- This code thus solves the problem of typed printf/scanf sharing the+-- same format string posed by Chung-chieh Shan.+--+-- Version: The current version is 1.1, Aug 31, 2008.+--+-- References+--+-- * The complete code with many examples.+-- <http://okmij.org/ftp/typed-formatting/PrintScan.hs>+--+-- * The initial view on typed sprintf and sscanf+-- <http://okmij.org/ftp/typed-formatting/PrintScanI.txt>+--+-- * The message with more explanations, posted on the Haskell mailing list+-- on Sun, 31 Aug 2008 19:40:41 -0700 (PDT)++module Text.PrintScan where++import Prelude hiding ((^))++data F a b where+ FLit :: String -> F a a+ FInt :: F a (Int -> a)+ FChr :: F a (Char -> a)+ FPP :: PrinterParser b -> F a (b -> a)+ (:^) :: F b c -> F a b -> F a c++-- | Printer/parsers (injection/projection pairs)+data PrinterParser a = PrinterParser (a -> String) (String -> Maybe (a,String))++-- | a bit of syntactic sugar to avoid hitting the Shift key too many a time+infixl 5 ^+(^) = (:^)+lit = FLit+int = FInt+char = FChr++fmt :: (Show b, Read b) => b -> F a (b -> a)+fmt x = FPP showread+++-- | The interpreter for printf +-- It implements Asai's accumulator-less alternative to+-- Danvy's functional unparsing++intp :: F a b -> (String -> a) -> b+intp (FLit str) k = k str+intp FInt k = \x -> k (show x)+intp FChr k = \x -> k [x]+intp (FPP (PrinterParser pr _)) k = \x -> k (pr x)+intp (a :^ b) k = intp a (\sa -> intp b (\sb -> k (sa ++ sb)))+++-- | The interpreter for scanf+ints :: F a b -> String -> b -> Maybe (a,String)+ints (FLit str) inp x = maybe Nothing (\inp' -> Just (x,inp')) $ prefix str inp+ints FChr (c:inp) f = Just (f c,inp)+ints FChr "" f = Nothing+ints (FPP (PrinterParser _ pa)) inp f = + maybe Nothing (\(v,s) -> Just (f v,s)) $ pa inp +ints FInt inp f = ints (FPP showread) inp f+ints (a :^ b) inp f = maybe Nothing (\(vb,inp') -> ints b inp' vb) $ + ints a inp f+++sprintf :: F String b -> b+sprintf fmt = intp fmt id++sscanf :: String -> F a b -> b -> Maybe a+sscanf inp fmt f = maybe Nothing (Just . fst) $ ints fmt inp f+++-- Tests++tp1 = sprintf $ lit "Hello world"+-- "Hello world"+ts1 = sscanf "Hello world" (lit "Hello world") ()+-- Just ()++tp2 = sprintf (lit "Hello " ^ lit "world" ^ char) '!'+-- "Hello world!"+ts2 = sscanf "Hello world!" (lit "Hello " ^ lit "world" ^ char) id+-- Just '!'++fmt3 = lit "The value of " ^ char ^ lit " is " ^ int+tp3 = sprintf fmt3 'x' 3+-- "The value of x is 3"+ts3 = sscanf "The value of x is 3" fmt3 (\c i -> (c,i))+-- Just ('x',3)++tp4 = sprintf (lit "abc" ^ int ^ lit "cde") 5+-- "abc5cde"+ts4 = sscanf "abc5cde" (lit "abc" ^ int ^ lit "cde") id+-- Just 5++-- | The format specification is first-class. One can build format specification+-- incrementally+-- This is not the case with OCaml's printf/scanf (where the +-- format specification has a weird typing and is not first class).+fmt50 = lit "abc" ^ int ^ lit "cde" +fmt5 = fmt50 ^ fmt (undefined::Float) ^ char+tp5 = sprintf fmt5 5 15 'c'+-- "abc5cde15.0c"+ts5 = sscanf "abc5cde15.0c" fmt5 (\i f c -> (i,f,c))+-- Just (5,15.0,'c')+++-- Utility functions++-- | Primitive Printer/parsers+showread :: (Show a, Read a) => PrinterParser a+showread = PrinterParser show parse+ where+ parse s = case reads s of+ [(v,s')] -> Just (v,s')+ _ -> Nothing++-- | A better prefixOf function+-- prefix patt str --> Just str'+-- if the String patt is the prefix of String str. The result str'+-- is str with patt removed+-- Otherwise, the result is Nothing++prefix :: String -> String -> Maybe String+prefix "" str = Just str+prefix (pc:pr) (sc:sr) | pc == sc = prefix pr sr+prefix _ _ = Nothing
+ Text/PrintScanF.hs view
@@ -0,0 +1,145 @@+-- Haskell98!++-- | The final view to the typed sprintf and sscanf+--+-- <http://okmij.org/ftp/typed-formatting/FPrintScan.html>+--+-- This code defines a simple domain-specific language of string+-- patterns and demonstrates two interpreters of the language:+-- for building strings (sprintf) and parsing strings (sscanf).+-- This code thus solves the problem of typed printf/scanf sharing the+-- same format string posed by Chung-chieh Shan.+-- This code presents scanf/printf interpreters in the final style;+-- it is thus the dual of the code in PrintScan.hs+--+-- Version: The current version is 1.1, Sep 2, 2008.+--+-- References+--+-- * The complete Haskell98 code with many examples.+-- <http://okmij.org/ftp/typed-formatting/PrintScanF.hs>+--+-- * The final view on typed sprintf and sscanf+-- <http://okmij.org/ftp/typed-formatting/PrintScanF.txt>+--+-- * The message posted on the Haskell mailing list on Tue, 2 Sep 2008 00:57:18 -0700 (PDT)+--++module Text.PrintScanF where++import Prelude hiding ((^))++class FormattingSpec repr where+ lit :: String -> repr a a+ int :: repr a (Int -> a)+ char :: repr a (Char -> a)+ fpp :: PrinterParser b -> repr a (b -> a)+ (^) :: repr b c -> repr a b -> repr a c+infixl 5 ^++-- Printer/parsers (injection/projection pairs)+data PrinterParser a = PrinterParser (a -> String) (String -> Maybe (a,String))++fmt :: (FormattingSpec repr, Show b, Read b) => b -> repr a (b -> a)+fmt x = fpp showread+++-- The interpreter for printf +-- It implements Asai's accumulator-less alternative to+-- Danvy's functional unparsing++newtype FPr a b = FPr ((String -> a) -> b)++instance FormattingSpec FPr where+ lit str = FPr $ \k -> k str+ int = FPr $ \k -> \x -> k (show x)+ char = FPr $ \k -> \x -> k [x]+ fpp (PrinterParser pr _) = FPr $ \k -> \x -> k (pr x)+ (FPr a) ^ (FPr b) = FPr $ \k -> a (\sa -> b (\sb -> k (sa ++ sb)))+++-- The interpreter for scanf+newtype FSc a b = FSc (String -> b -> Maybe (a,String))++instance FormattingSpec FSc where+ lit str = FSc $ \inp x -> + maybe Nothing (\inp' -> Just (x,inp')) $ prefix str inp+ char = FSc $ \inp f -> case inp of+ (c:inp) -> Just (f c,inp)+ "" -> Nothing+ fpp (PrinterParser _ pa) = FSc $ \inp f ->+ maybe Nothing (\(v,s) -> Just (f v,s)) $ pa inp+ int = fpp showread+ (FSc a) ^ (FSc b) = FSc $ \inp f ->+ maybe Nothing (\(vb,inp') -> b inp' vb) $ a inp f++sprintf :: FPr String b -> b+sprintf (FPr fmt) = fmt id++sscanf :: String -> FSc a b -> b -> Maybe a+sscanf inp (FSc fmt) f = maybe Nothing (Just . fst) $ fmt inp f+++-- One can easily build another interpreter, to convert a formatting+-- specification to a C-style formatting string+++-- Tests++tp1 = sprintf $ lit "Hello world"+-- "Hello world"+ts1 = sscanf "Hello world" (lit "Hello world") ()+-- Just ()++tp2 = sprintf (lit "Hello " ^ lit "world" ^ char) '!'+-- "Hello world!"+ts2 = sscanf "Hello world!" (lit "Hello " ^ lit "world" ^ char) id+-- Just '!'++-- Unit is to keep the type of fmt3 polymorphic and away from the+-- monomorphism restriction+fmt3 () = lit "The value of " ^ char ^ lit " is " ^ int+tp3 = sprintf (fmt3 ()) 'x' 3+-- "The value of x is 3"+ts3 = sscanf "The value of x is 3" (fmt3 ()) (\c i -> (c,i))+-- Just ('x',3)++tp4 = sprintf (lit "abc" ^ int ^ lit "cde") 5+-- "abc5cde"+ts4 = sscanf "abc5cde" (lit "abc" ^ int ^ lit "cde") id+-- Just 5++-- The format specification is first-class. One can build format specification+-- incrementally+-- This is not the case with OCaml's printf/scanf (where the +-- format specification has a weird typing and is not first class).+-- Unit is to keep the type of fmt3 polymorphic and away from the+-- monomorphism restriction+fmt50 () = lit "abc" ^ int ^ lit "cde" +fmt5 () = fmt50 () ^ fmt (undefined::Float) ^ char+tp5 = sprintf (fmt5 ()) 5 15 'c'+-- "abc5cde15.0c"+ts5 = sscanf "abc5cde15.0c" (fmt5 ()) (\i f c -> (i,f,c))+-- Just (5,15.0,'c')+++-- Utility functions++-- Primitive Printer/parsers+showread :: (Show a, Read a) => PrinterParser a+showread = PrinterParser show parse+ where+ parse s = case reads s of+ [(v,s')] -> Just (v,s')+ _ -> Nothing++-- A better prefixOf function+-- prefix patt str --> Just str'+-- if the String patt is the prefix of String str. The result str'+-- is str with patt removed+-- Otherwise, the result is Nothing++prefix :: String -> String -> Maybe String+prefix "" str = Just str+prefix (pc:pr) (sc:sr) | pc == sc = prefix pr sr+prefix _ _ = Nothing
+ liboleg.cabal view
@@ -0,0 +1,30 @@+name: liboleg+version: 0.1+license: BSD3+license-file: LICENSE+author: Oleg Kiselyov+maintainer: Don Stewart <dons@galois.com>+homepage: http://okmij.org/ftp/+category: Text+synopsis: A collection of Oleg Kiselyov's Haskell modules+description: A collection of Oleg Kiselyov's Haskell modules (released with his permission)+build-type: Simple+stability: experimental+cabal-version: >= 1.2++library+ build-depends:+ base, containers++ exposed-modules:+ Data.FDList+ Text.PrintScan+ Text.PrintScanF++--+-- extensions: +-- GADTs+--++ ghc-options:+ -funbox-strict-fields