first commit

reverse.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE
+    UnicodeSyntax
+#-}
+
+module Main where
+
+import Prelude hiding (iterate, reverse)
+import Data.IORef
+
+
+
+data LinkedList a
+  = None
+  | Node { value ∷ IORef a
+         , next  ∷ IORef (LinkedList a)
+         }
+
+
+linkedlist ∷ a → IO (LinkedList a)
+linkedlist x =
+  do
+    v ← newIORef x
+    n ← newIORef None
+    pure $ Node { value = v , next = n }
+
+
+get_value ∷ LinkedList a → IO a
+get_value n =
+  case n of
+    None → error "Empty"
+    node → (readIORef $ value node) >>= \ x → pure x
+
+
+set_value ∷ a → LinkedList a → IO ()
+set_value x n =
+  case n of
+    None → pure ()
+    node → writeIORef (value node) x
+
+
+get_next ∷ LinkedList a → IO (LinkedList a)
+get_next n =
+  case n of
+    None → error "Empty"
+    node → (readIORef $ next node) >>= \x → pure x
+
+
+set_next ∷ LinkedList a → LinkedList a → IO ()
+set_next n1 n2 =
+  case n1 of
+    None → pure ()
+    node → writeIORef (next node) n2
+
+
+reverse ∷ LinkedList a → IO (LinkedList a)
+reverse l =
+
+    let reverse' ∷ LinkedList a → LinkedList a → IO (LinkedList a)
+        reverse' n1 n2 =
+          case n2 of
+            None → pure n1
+            _    → do
+              n3 ← get_next n2
+              set_next n2 n1
+              reverse' n2 n3
+    in
+
+    reverse' None l
+
+
+iterate ∷ (a → IO ()) -> LinkedList a -> IO ()
+iterate f l =
+  case l of
+    None → pure ()
+    _    →
+      do
+        v ← get_value l
+        f v
+        n ← get_next l
+        iterate f n
+
+
+print_list ∷ Show a ⇒ LinkedList a → IO ()
+print_list l =
+  iterate (\ x → putStr $ show x ++ " ") l
+
+
+
+main ∷ IO ()
+main =
+  do
+    l1 ← linkedlist 1
+    l2 ← linkedlist 2
+    l3 ← linkedlist 3
+    l4 ← linkedlist 4
+    l5 ← linkedlist 5
+
+    let lists = [ ("l1", l1) , ("l2", l2) ,
+                  ("l3", l3) , ("l4", l4) ,
+                  ("l5", l5)
+                ]
+
+    putStr "\n"
+
+    putStr ">>> Before linking the lists\n"
+    mapM_ (\ (s, l) →
+             do
+               putStr $ s ++ " : "
+               print_list l
+               putStr "\n"
+          )
+          lists
+
+    set_next l1 l2
+    set_next l2 l3
+    set_next l3 l4
+    set_next l4 l5
+
+    putStr "\n"
+
+    putStr ">>> After linking and before reversing the linked list\n"
+    mapM_ (\ (s, l) →
+             do
+               putStr $ s ++ " : "
+               print_list l
+               putStr "\n"
+          )
+          lists
+
+    putStr "\n"
+
+    putStr " The evaluation of `reverse l1´ computes the reversed\n\
+           \ list of l1 and the final result is equal to l5,\n\
+           \ the new head of the linked list.\n\n"
+
+    _ ← reverse l1
+
+    putStr ">>> After reversing the linked list\n"
+    mapM_ (\ (s, l) →
+             do
+               putStr $ s ++ " : "
+               print_list l
+               putStr "\n"
+          )
+          lists
+
+    putStr "\n"
+
+

reverse.ml

@@ -0,0 +1,165 @@
+
+
+exception Empty
+;;
+
+
+type 'a linked_list =
+  | None
+  | Node of
+      { value : 'a ref
+      ; next  : 'a linked_list ref
+      }
+;;
+
+
+let linked_list : 'a -> 'a linked_list =
+  fun x ->
+    Node { value = ref x
+         ; next  = ref None
+         }
+;;
+
+
+let get_value : 'a linked_list -> 'a =
+  fun l ->
+    match l with
+    | None   -> raise Empty
+    | Node r -> !(r.value)
+;;
+
+
+let set_value : 'a -> 'a linked_list -> unit =
+  fun value node ->
+    match node with
+    | None   -> ()
+    | Node r -> r.value := value
+;;
+
+
+let get_next : 'a linked_list -> 'a linked_list =
+  fun l ->
+    match l with
+    | None   -> raise Empty
+    | Node r -> !(r.next)
+;;
+
+
+let set_next : 'a linked_list -> 'a linked_list -> unit =
+  fun n1 n2 ->
+    match n1 with
+    | None   -> ()
+    | Node r -> r.next := n2
+;;
+
+
+let reverse : 'a linked_list -> 'a linked_list =
+  fun l ->
+
+    let rec reverse' : 'a linked_list -> 'a linked_list -> 'a linked_list =
+      fun n1 n2 ->
+        match n2 with
+        | None -> n1
+        | _    ->
+           let n3 = get_next n2
+           in
+           ( set_next n2 n1 ; reverse' n2 n3 )
+    in
+
+    match l with
+    | None -> None
+    | _    -> reverse' None l
+;;
+
+
+let rec iterate : ('a -> unit) -> 'a linked_list -> unit =
+  fun f l ->
+    match l with
+    | None -> ()
+    | _    -> ( f (get_value l) ; iterate f (get_next l) )
+;;
+
+
+let print_list : ('a -> string) -> 'a linked_list -> unit =
+  fun to_string l ->
+    iterate (fun n -> print_string ((to_string n) ^ " ")) l
+;;
+
+
+let print_a_list_of_strings : string linked_list -> unit =
+  fun l -> print_list (fun s -> s) l
+;;
+
+
+let print_a_list_of_ints : int linked_list -> unit =
+  fun l -> print_list (fun i -> string_of_int i) l
+;;
+
+
+
+let main =
+  let l1 = linked_list 1
+  and l2 = linked_list 2
+  and l3 = linked_list 3
+  and l4 = linked_list 4
+  and l5 = linked_list 5
+  in
+
+  let lists =
+    [ ("l1", l1) ; ("l2", l2)
+    ; ("l3", l3) ; ("l4", l4)
+    ; ("l5", l5)
+    ]
+  in
+
+  ( print_newline ()
+
+  ; print_string ">>> Before linking the lists\n"
+  ; List.iter (fun (s, l) ->
+                   print_string (s ^ " : " )
+                 ; print_a_list_of_ints l
+                 ; print_newline ()
+              )
+              lists
+
+  ; set_next l1 l2
+  ; set_next l2 l3
+  ; set_next l3 l4
+  ; set_next l4 l5
+
+  ; print_newline ()
+
+  ; print_string ">>> After linking and before reversing the linked list\n"
+  ; List.iter (fun (s, l) ->
+                   print_string (s ^ " : " )
+                 ; print_a_list_of_ints l
+                 ; print_newline ()
+              )
+              lists
+
+  ; print_newline ()
+
+  ; print_string " The evaluation of `reverse l1´ computes the reversed\n\
+                 \ list of l1 and the final result is equal to l5,\n\
+                 \ the new head of the linked list.\n\n"
+
+  ; let _ = reverse l1 in ()
+
+  ; print_string ">>> After reversing the linked list\n"
+  ; List.iter (fun (s, l) ->
+                   print_string (s ^ " : " )
+                 ; print_a_list_of_ints l
+                 ; print_newline ()
+              )
+              lists
+
+  ; print_newline ()
+  )
+;;
+
+
+
+let () = main
+;;
+
+