diff --git a/Data/FDList.hs b/Data/FDList.hs new file mode 100644 --- /dev/null +++ b/Data/FDList.hs @@ -0,0 +1,254 @@ +-- | Haskell98 +-- +-- +-- +-- 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] + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Text/PrintScan.hs b/Text/PrintScan.hs new file mode 100644 --- /dev/null +++ b/Text/PrintScan.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE GADTs #-} + +-- | +-- +-- +-- +-- 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. +-- +-- +-- * The initial view on typed sprintf and sscanf +-- +-- +-- * 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 diff --git a/Text/PrintScanF.hs b/Text/PrintScanF.hs new file mode 100644 --- /dev/null +++ b/Text/PrintScanF.hs @@ -0,0 +1,145 @@ +-- Haskell98! + +-- | The final 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. +-- 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. +-- +-- +-- * The final view on typed sprintf and sscanf +-- +-- +-- * 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 diff --git a/liboleg.cabal b/liboleg.cabal new file mode 100644 --- /dev/null +++ b/liboleg.cabal @@ -0,0 +1,30 @@ +name: liboleg +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Oleg Kiselyov +maintainer: Don Stewart +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