1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
let move_to_top x xs = x :: List.filter (( != ) x) xs
let wrapped_search p l lst =
let rec aux (wrapped : bool) = function
| x :: _ when p x -> Some x
| [ x ] when not wrapped -> l x |> aux true
| _ :: xs -> aux wrapped xs
| [] -> None
in
aux false lst
;;
let next_or_first e = function
| [] -> None
| first :: _ as lst ->
let rec aux = function
| x :: y :: _ when x == e -> Some y
| [ x ] when x == e -> Some first
| _ :: rest -> aux rest
| [] -> None
in
aux lst
;;
let prev_or_last e lst = List.rev lst |> next_or_first e
let shift_right p l =
let rec aux acc = function
| [ x ] when p x -> x :: List.rev acc
| x :: y :: xs when p x -> (List.rev @@ (x :: y :: acc)) @ xs
| x :: xs -> aux (x :: acc) xs
| [] -> List.rev acc
in
aux [] l
;;
let shift_left p l = List.rev l |> shift_right p |> List.rev
let hop_right sel vis l =
let rec aux p before = function
| x :: xs when p x -> Some (List.rev before, x, xs)
| x :: xs -> aux p (x :: before) xs
| [] -> None
in
match aux sel [] l with
| None -> l
| Some (b, x, a) ->
(match aux vis [] a with
| Some (b', y, a') -> b @ b' @ [ y; x ] @ a'
| None ->
(match aux vis [] b with
| Some (b', y, a') -> b' @ [ x; y ] @ a' @ a
| None -> l))
;;
let hop_left sel vis l = List.rev l |> hop_right sel vis |> List.rev
let rearrange vis order l =
List.fold_left_map
(fun ol slot ->
if vis slot
then (
match ol with
| [] ->
invalid_arg
"order does not contain all the elements of the list that satisfy vis"
| x :: xs -> xs, x)
else ol, slot)
order
l
|> snd
;;
let insert_relative ~after ~point ~e stack =
let rec aux = function
| [] -> [ e ]
| x :: xs when x == point -> if after then x :: e :: xs else e :: x :: xs
| x :: xs -> x :: aux xs
in
List.filter (( != ) e) stack |> aux
;;