(* XList, a tail recursion only implementation of the OCaml list library.
* Copyright (C) 2003 Brian Hurt
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
(* Thanks to Olivier Andrieu for this routine.
* DO NOT USE IT unless you really know what you're doing.
*)
let setcdr : 'a list -> 'a list -> unit = fun c v ->
let c = Obj.repr c in
(* assert(Obj.is_block c) ; *)
Obj.set_field c 1 (Obj.repr v)
;;
let length l =
let rec loop l len =
match l with
[] -> len
| h :: t -> loop t (len + 1)
in
loop l 0
;;
let hd = function
[] -> failwith "hd"
| h :: t -> h
;;
let tl = function
[] -> failwith "tl"
| h :: t -> t
;;
let rec nth l n =
match l with
[] -> failwith "nth"
| h :: t ->
if (n = 0) then h
else if (n > 0) then nth t (n - 1)
else invalid_arg "XList.nth"
;;
let duplicate l =
let rec loop dst src =
match src with
[] -> dst
| h :: t ->
let newdst = [ h ] in
setcdr dst newdst ;
loop newdst t
in
match l with
[] -> assert false
| h :: t ->
let hd = [ h ] in
(hd, (loop hd t))
;;
let append l1 l2 =
match l1 with
[] -> l2
| _ ->
let hd, tl = duplicate l1 in
setcdr tl l2;
hd
;;
let rec rev_append l1 l2 =
match l1 with
[] -> l2
| h :: t -> rev_append t (h :: l2)
;;
let rev l = rev_append l [] ;;
let flatten lst =
let rec loop dst src =
match src with
[] -> ()
| h :: t ->
let a, b = duplicate h in
setcdr dst a;
loop b t
in
match lst with
[] -> []
| h :: t ->
let a, b = duplicate h in
loop b t;
a
;;
let concat = flatten ;;
let map f lst =
let rec loop dst src =
match src with
[] -> ()
| h :: t ->
let r = [ f h ] in
setcdr dst r;
loop r t
in
match lst with
[] -> []
| h :: t ->
let r = [ f h ] in
loop r t;
r
;;
let rev_map f l =
let rec loop accum src =
match src with
[] -> accum
| h :: t -> loop ((f h) :: accum) t
in
loop [] l
;;
let rec iter f = function
[] -> ()
| h :: t -> f h ; iter f t
;;
let rec fold_left f accum l =
match l with
[] -> accum
| h :: t -> fold_left f (f accum h) t
;;
(* fold_right does a list reversal rather than being tail recursive.
* This means that the original implementation *might* be faster.
* But this implementation is tail recursive.
*)
let fold_right f l accum =
let rec loop lst accum =
match lst with
[] -> accum
| h :: t -> loop t (f h accum)
in
loop (rev l) accum
;;
let rec fold_right' f l accum =
match l with
[] -> accum
| h :: t -> f h (fold_right f t accum)
;;
let map2 f l1 l2 =
let rec loop dst src1 src2 =
match (src1, src2) with
([], []) -> ()
| (h1 :: t1, h2 :: t2) ->
let r = [ f h1 h2 ] in
setcdr dst r;
loop r t1 t2
| _ -> invalid_arg "XList.map2"
in
match (l1, l2) with
([], []) -> []
| (h1 :: t1, h2 :: t2) ->
let r = [ f h1 h2 ] in
loop r t1 t2;
r
| _ -> invalid_arg "XList.map2"
;;
let rec iter2 f l1 l2 =
match (l1, l2) with
([], []) -> ()
| (h1 :: t1, h2 :: t2) -> f h1 h2; iter2 f t1 t2
| _ -> invalid_arg "XList.iter2"
;;
let rec fold_left2 f accum l1 l2 =
match (l1, l2) with
([], []) -> accum
| (h1 :: t1, h2 :: t2) -> fold_left2 f (f accum h1 h2) t1 t2
| _ -> invalid_arg "XList.fold_left2"
;;
let fold_right2 f l1 l2 accum =
let rec loop l1 l2 accum =
match (l1, l2) with
([], []) -> accum
| (h1 :: t1, h2 :: t2) -> loop t1 t2 (f h1 h2 accum)
| _ -> invalid_arg "XList.fold_right2"
in
loop (rev l1) (rev l2) accum
;;
let rec fold_right2' f l1 l2 accum =
match (l1, l2) with
([], []) -> accum
| (h1 :: t1, h2 :: t2) -> f h1 h2 (fold_right2' f t1 t2 accum)
| _ -> invalid_arg "XList.fold_right2'"
;;
let for_all p l =
let rec loop l =
match l with
[] -> true
| h :: t ->
if (p h) then loop t
else false
in
loop l
;;
let exists p l =
let rec loop l =
match l with
[] -> false
| h :: t ->
if (p h) then true
else loop t
in
loop l
;;
let for_all2 p l1 l2 =
let rec loop l1 l2 =
match (l1, l2) with
([], []) -> true
| (h1 :: t1, h2 :: t2) ->
if (p h1 h2) then loop t1 t2
else false
| _ -> invalid_arg "XList.for_all2"
in
loop l1 l2
;;
let exists2 p l1 l2 =
let rec loop l1 l2 =
match (l1, l2) with
([], []) -> false
| (h1 :: t1, h2 :: t2) ->
if (p h1 h2) then true
else loop t1 t2
| _ -> invalid_arg "XList.exists2"
in
loop l1 l2
;;
let rec mem x = function
[] -> false
| h :: t -> if (h = x) then true else mem x t
;;
let rec memq x = function
[] -> false
| h :: t -> if (h == x) then true else mem x t
;;
let rec assoc x = function
[] -> raise Not_found
| (a, b) :: t -> if (a = x) then b else assoc x t
;;
let rec assq x = function
[] -> raise Not_found
| (a, b) :: t -> if (a == x) then b else assoc x t
;;
let rec mem_assoc x = function
[] -> false
| (a, b) :: t -> if (a = x) then true else mem_assoc x t
;;
let rec mem_assq x = function
[] -> false
| (a, b) :: t -> if (a == x) then true else mem_assoc x t
;;
let remove_assoc x l =
let rec loop dst = function
[] -> ()
| (a, _ as pair) :: t ->
if (a = x) then
setcdr dst t
else
let r = [ pair ] in
begin
setcdr dst r;
loop r t
end
in
match l with
[] -> []
| (a, _ as pair) :: t ->
if (a = x) then
t
else
let r = [ pair ] in
loop r t;
r
;;
let remove_assq x l =
let rec loop dst = function
[] -> ()
| (a, _ as pair) :: t ->
if (a == x) then
setcdr dst t
else
let r = [ pair ] in
begin
setcdr dst r;
loop r t
end
in
match l with
[] -> []
| (a, _ as pair) :: t ->
if (a == x) then
t
else
let r = [ pair ] in
loop r t;
r
;;
let rec find p = function
[] -> raise Not_found
| h :: t -> if (p h) then h else find p t
;;
let find_all p l =
let rec findnext dst = function
[] -> ()
| h :: t ->
if (p h) then
let r = [ h ] in
begin
setcdr dst r;
findnext r t
end
else
findnext dst t
in
let rec findfirst = function
[] -> []
| h :: t ->
if (p h) then
let r = [ h ] in
begin
findnext r t ;
r
end
else
findfirst t
in
findfirst l
;;
let filter = find_all ;;
let partition p l =
let rec both yesdst nodst = function
[] -> ()
| h :: t ->
let r = [ h ] in
if (p h) then
begin
setcdr yesdst r ;
both r nodst t
end
else
begin
setcdr nodst r ;
both yesdst r t
end
in
let rec yesonly yesdst = function
[] -> []
| h :: t ->
let r = [ h ] in
if (p h) then
begin
setcdr yesdst r;
yesonly r t
end
else
begin
both yesdst r t ;
r
end
in
let rec noonly nodst = function
[] -> []
| h :: t ->
let r = [ h ] in
if (p h) then
begin
both r nodst t ;
r
end
else
begin
setcdr nodst r ;
noonly r t
end
in
match l with
[] -> ([], [])
| h :: t ->
let r = [ h ] in
if (p h) then
(r, (yesonly r t))
else
((noonly r t), r)
;;
let split lst =
let rec loop adst bdst = function
[] -> ()
| (a, b) :: t ->
let x = [ a ]
and y = [ b ]
in
setcdr adst x ;
setcdr bdst y ;
loop x y t
in
match lst with
[] -> ([], [])
| (a, b) :: t ->
let x = [ a ]
and y = [ b ]
in
loop x y t ;
(x, y)
;;
let combine l1 l2 =
let rec loop dst l1 l2 =
match (l1, l2) with
([], []) -> ()
| (h1 :: t1, h2 :: t2) ->
let r = [ h1, h2 ] in
begin
setcdr dst r ;
loop r t1 t2
end
| (_, _) -> invalid_arg "XList.combine"
in
match (l1, l2) with
([], []) -> []
| (h1 :: t1, h2 :: t2) ->
let r = [ h1, h2 ] in
begin
loop r t1 t2 ;
r
end
| (_, _) -> invalid_arg "XList.combine"
;;
(* Note that unlike the standard sort, I don't do direct sorting on three-
* element lists. On the other hand, I don't have to reverse my lists
* either, so I probably win.
*)
let rec sort cmp lst =
let rec splitloop dst1 dst2 lst =
match lst with
[] -> ()
| a :: [] -> setcdr dst1 [ a ]
| a :: b :: t ->
let x = [ a ]
and y = [ b ]
in
setcdr dst1 x ;
setcdr dst2 y ;
splitloop x y t
in
let rec combineloop dst lst1 lst2 =
match (lst1, lst2) with
([], []) -> ()
| ([], _) -> setcdr dst lst2
| (_, []) -> setcdr dst lst1
| ( h1 :: t1, h2 :: t2) ->
if ((cmp h1 h2) <= 0) then
let r = [ h1 ] in
begin
setcdr dst r ;
combineloop r t1 lst2
end
else
let r = [ h2 ] in
begin
setcdr dst r ;
combineloop r lst1 t2
end
in
let combine l1 l2 =
match (l1, l2) with
([], []) -> []
| ([], _) -> l2
| (_, []) -> l1
| (h1 :: t1, h2 :: t2 ) ->
if ((cmp h1 h2) <= 0) then
let r = [ h1 ] in
begin
combineloop r t1 l2;
r
end
else
let r = [ h2 ] in
begin
combineloop r l1 t2 ;
r
end
in
match lst with
[] -> []
| a :: [] -> lst
| a :: b :: t ->
let x = [ a ]
and y = [ b ]
in
begin
splitloop x y t ;
combine (sort cmp x) (sort cmp y)
end
;;