@ -7,45 +7,20 @@
(* * Terms *) (* * Terms *)
(* * Representation of Arithmetic terms *) (* Define term type using polymorphic arithmetic type, with derived compare,
module rec Arith0 : equal , and sexp_of functions * )
( Arithmetic . REPRESENTATION
module Trm1 = struct
with type var := Trm . Var1 . t
type compare [ @@ deriving compare , equal , sexp ]
with type trm := Trm . t ) =
Arithmetic . Representation
( Trm . Var1 )
( struct
include Trm
include Comparer . Make ( Trm )
end )
(* * Arithmetic terms *) type arith = ( t , compare ) Arithmetic . t
and Arith : ( Arithmetic . S with type trm := Trm . t with type t = Arith0 . t ) =
struct
include Arith0
include Make ( struct
let to_trm = Trm . _Arith
let get_arith ( e : Trm . t ) =
match e with
| Z z -> Some ( Arith . const ( Q . of_z z ) )
| Q q -> Some ( Arith . const q )
| Arith a -> Some a
| _ -> None
end )
end
(* * Terms, built from variables and applications of function symbols from and t =
various theories . Denote functions from structures to values . * )
and Trm : sig
type t = private
(* variables *)
(* variables *)
| Var of { id : int ; name : string }
| Var of { id : int ; name : string [ @ ignore ] }
(* arithmetic *)
(* arithmetic *)
| Z of Z . t
| Z of Z . t
| Q of Q . t
| Q of Q . t
| Arith of Arith . t
| Arith of arith
(* sequences ( of flexible size ) *)
(* sequences ( of flexible size ) *)
| Splat of t
| Splat of t
| Sized of { seq : t ; siz : t }
| Sized of { seq : t ; siz : t }
@ -54,50 +29,20 @@ and Trm : sig
(* uninterpreted *)
(* uninterpreted *)
| Apply of Funsym . t * t array
| Apply of Funsym . t * t array
[ @@ deriving compare , equal , sexp ]
[ @@ deriving compare , equal , sexp ]
end
(* * Variable terms, represented as a subtype of general term s *) (* Add comparer, needed to instantiate arithmetic and container *)
module Var1 : sig module Trm2 = struct
type trm := t
include Comparer . Counterfeit ( Trm1 )
include Trm1
include Var_intf . S with type t = private trm end
val of_ : trm -> t
(* Specialize arithmetic type and define operations using comparer *)
val of_trm : trm -> t option
module Arith0 = Arithmetic . Make ( Trm2 )
end
val ppx : Var1 . strength -> t pp
(* Add ppx, defined recursively with Arith0.ppx *)
val pp : t pp
module Trm3 = struct
include Trm2
include Invariant . S with type t := t
val _ Var : int -> string -> t
val _ Z : Z . t -> t
val _ Q : Q . t -> t
val _ Arith : Arith . t -> t
val _ Splat : t -> t
val _ Sized : seq : t -> siz : t -> t
val _ Extract : seq : t -> off : t -> len : t -> t
val _ Concat : t array -> t
val _ Apply : Funsym . t -> t array -> t
val add : t -> t -> t
val sub : t -> t -> t
val seq_size_exn : t -> t
val seq_size : t -> t option
val get_z : t -> Z . t option
val get_q : t -> Q . t option
val vars : t -> Var1 . t iter
end = struct
type t =
| Var of { id : int ; name : string [ @ ignore ] }
| Z of Z . t
| Q of Q . t
| Arith of Arith . t
| Splat of t
| Sized of { seq : t ; siz : t }
| Extract of { seq : t ; off : t ; len : t }
| Concat of t array
| Apply of Funsym . t * t array
[ @@ deriving compare , equal , sexp ]
(* nul-terminated string value represented by a concatenation *)
(* nul-terminated string value represented by a concatenation *)
let string_of_concat xs =
let string_of_concat xs =
@ -136,7 +81,7 @@ end = struct
| Some ` Anonymous -> Trace . pp_styled ` Cyan " _ " fs )
| Some ` Anonymous -> Trace . pp_styled ` Cyan " _ " fs )
| Z z -> Trace . pp_styled ` Magenta " %a " fs Z . pp z
| Z z -> Trace . pp_styled ` Magenta " %a " fs Z . pp z
| Q q -> Trace . pp_styled ` Magenta " %a " fs Q . pp q
| Q q -> Trace . pp_styled ` Magenta " %a " fs Q . pp q
| Arith a -> Arith . ppx ( ppx strength ) fs a
| Arith a -> Arith 0 . ppx ( ppx strength ) fs a
| Splat x -> pf " %a^ " pp x
| Splat x -> pf " %a^ " pp x
| Sized { seq ; siz } -> pf " @<1>⟨%a,%a@<1>⟩ " pp siz pp seq
| Sized { seq ; siz } -> pf " @<1>⟨%a,%a@<1>⟩ " pp siz pp seq
| Extract { seq ; off ; len } -> pf " %a[%a,%a) " pp seq pp off pp len
| Extract { seq ; off ; len } -> pf " %a[%a,%a) " pp seq pp off pp len
@ -157,255 +102,97 @@ end = struct
pp fs trm
pp fs trm
let pp = ppx ( fun _ -> None )
let pp = ppx ( fun _ -> None )
let pp_diff fs ( x , y ) = Format . fprintf fs " -- %a ++ %a " pp x pp y
end
(* Define variables as a subtype of terms *)
(* Define containers over terms *)
module Var1 = struct
module Set = struct
module V = struct
include Set . Make ( Trm3 )
module T = struct
include Provide_of_sexp ( Trm3 )
type nonrec t = t [ @@ deriving compare , equal , sexp ]
include Provide_pp ( Trm3 )
type strength = t -> [ ` Universal | ` Existential | ` Anonymous ] option
end
let pp = pp
let ppx = ppx
end
include T
let invariant x =
let @ () = Invariant . invariant [ % here ] x [ % sexp_of : t ] in
match x with
| Var _ -> ()
| _ -> fail " non-var: %a " Sexp . pp_hum ( sexp_of_t x ) ()
let make ~ id ~ name = Var { id ; name } | > check invariant
let id = function Var v -> v . id | x -> violates invariant x
let name = function Var v -> v . name | x -> violates invariant x
module Set = struct
module S = NS . Set . Make ( T )
include S
include Provide_of_sexp ( T )
include Provide_pp ( T )
let ppx strength vs = S . pp_full ( ppx strength ) vs
let pp_xs fs xs =
if not ( is_empty xs ) then
Format . fprintf fs " @<2>∃ @[%a@] .@;<1 2> " pp xs
end
module Map = struct
include NS . Map . Make ( T )
include Provide_of_sexp ( T )
end
let fresh name ~ wrt =
let max =
match Set . max_elt wrt with None -> 0 | Some m -> max 0 ( id m )
in
let x' = make ~ id : ( max + 1 ) ~ name in
( x' , Set . add x' wrt )
let freshen v ~ wrt = fresh ( name v ) ~ wrt
let program ? ( name = " " ) ~ id =
assert ( id > 0 ) ;
make ~ id : ( - id ) ~ name
let identified ~ name ~ id = make ~ id ~ name
let of_ v = v | > check invariant
let of_trm = function Var _ as v -> Some v | _ -> None
end
include V
module Map = struct
module Subst = Subst . Make ( V )
include Map . Make ( Trm3 )
end
include Provide_of_sexp ( Trm3 )
end
let invariant e =
(* Define variables as a subtype of terms *)
let @ () = Invariant . invariant [ % here ] e [ % sexp_of : t ] in
module Var = struct
match e with
open Trm3
| Q q -> assert ( not ( Z . equal Z . one ( Q . den q ) ) )
| Arith a -> (
match Arith . classify a with
| Trm _ | Const _ -> assert false
| _ -> () )
| _ -> ()
(* * Destruct *)
module V = struct
type nonrec t = t [ @@ deriving compare , equal , sexp ]
type strength = t -> [ ` Universal | ` Existential | ` Anonymous ] option
let get_z = function Z z -> Some z | _ -> None
let pp = pp
let get_q = function Q q -> Some q | Z z -> Some ( Q . of_z z ) | _ -> None
let ppx = ppx
(* * Construct *)
let invariant x =
let @ () = Invariant . invariant [ % here ] x [ % sexp_of : t ] in
match x with
| Var _ -> ()
| _ -> fail " non-var: %a " Sexp . pp_hum ( sexp_of_t x ) ()
let _ Var id name = Var { id ; name } | > check invariant
let make ~ id ~ name = Var { id ; name } | > check invariant
let id = function Var v -> v . id | x -> violates invariant x
let name = function Var v -> v . name | x -> violates invariant x
(* statically allocated since they are tested with == *)
module Set = struct
let zero = Z Z . zero | > check invariant
include Set
let one = Z Z . one | > check invariant
let _ Z z =
let ppx strength vs = pp_full ( ppx strength ) vs
( if Z . equal Z . zero z then zero else if Z . equal Z . one z then one else Z z )
| > check invariant
let _ Q q =
let pp_xs fs xs =
( if Z . equal Z . one ( Q . den q ) then _ Z ( Q . num q ) else Q q )
if not ( is_empty xs ) then
| > check invariant
Format . fprintf fs " @<2>∃ @[%a@] .@;<1 2> " pp xs
end
let _ Arith a =
module Map = Map
( match Arith . classify a with
| Trm e -> e
| Const q -> _ Q q
| _ -> Arith a )
| > check invariant
let add x y = _ Arith Arith . ( add ( trm x ) ( trm y ) )
let fresh name ~ wrt =
let sub x y = _ Arith Arith . ( sub ( trm x ) ( trm y ) )
let max =
match Set . max_elt wrt with None -> 0 | Some m -> max 0 ( id m )
in
let x' = make ~ id : ( max + 1 ) ~ name in
( x' , Set . add x' wrt )
let _ Splat x =
let freshen v ~ wrt = fresh ( name v ) ~ wrt
(* 0^ ==> 0 *)
( if x = = zero then x else Splat x ) | > check invariant
let seq_size_exn =
let program ? ( name = " " ) ~ id =
let invalid = Invalid_argument " seq_size_exn " in
assert ( id > 0 ) ;
let rec seq_size_exn = function
make ~ id : ( - id ) ~ name
| Sized { siz = n } | Extract { len = n } -> n
| Concat a0U ->
Array . fold ~ f : ( fun aJ a0I -> add a0I ( seq_size_exn aJ ) ) a0U zero
| _ -> raise invalid
in
seq_size_exn
let seq_size e =
let identified ~ name ~ id = make ~ id ~ name
try Some ( seq_size_exn e ) with Invalid_argument _ -> None
let of_ v = v | > check invariant
let of_trm = function Var _ as v -> Some v | _ -> None
end
let _ Sized ~ seq ~ siz =
include V
( match seq_size seq with
module Subst = Subst . Make ( V )
(* ⟨n,α⟩ ==> α α *)
end
| Some n when equal siz n -> seq
| _ -> Sized { seq ; siz } )
| > check invariant
let partial_compare x y =
(* Add definitions needed for arithmetic embedding into terms *)
match sub x y with
module Trm = struct
| Z z -> Some ( Int . sign ( Z . sign z ) )
include Trm3
| Q q -> Some ( Int . sign ( Q . sign q ) )
| _ -> None
let partial_ge x y =
(* * Invariant *)
match partial_compare x y with Some ( Pos | Zero ) -> true | _ -> false
let empty_seq = Concat [| |]
let rec _ Extract ~ seq ~ off ~ len =
[ % trace ]
~ call : ( fun { pf } -> pf " @ %a " pp ( Extract { seq ; off ; len } ) )
~ retn : ( fun { pf } -> pf " %a " pp )
@@ fun () ->
(* _[_,0 ) ==> ⟨⟩ *)
( if equal len zero then empty_seq
else
let o_l = add off len in
match seq with
(* α ) [o,l ) ==> α ) when k ≥ o+l *)
| Extract { seq = a ; off = m ; len = k } when partial_ge k o_l ->
_ Extract ~ seq : a ~ off : ( add m off ) ~ len
(* ⟨n,0⟩[o,l ) ==> ⟨l,0⟩ when n ≥ o+l *)
| Sized { siz = n ; seq } when seq = = zero && partial_ge n o_l ->
_ Sized ~ seq ~ siz : len
(* ⟨n,E^⟩[o,l ) ==> ⟨l,E^⟩ when n ≥ o+l *)
| Sized { siz = n ; seq = Splat _ as e } when partial_ge n o_l ->
_ Sized ~ seq : e ~ siz : len
(* ⟨n,a⟩[0,n ) ==> ⟨n,a⟩ *)
| Sized { siz = n } when equal off zero && equal n len -> seq
(* For ( α₀^α₁ ) [o,l ) there are 3 cases:
*
* ⟨ .. . ⟩ ^ ⟨ .. . ⟩
* [ , )
* o < o + l ≤ | α ₀ | : ( α ₀ ^ α ₁ ) [ o , l ) = = > α ₀ [ o , l ) ^ α ₁ [ 0 , 0 )
*
* ⟨ .. . ⟩ ^ ⟨ .. . ⟩
* [ , )
* o ≤ | α ₀ | < o + l : ( α ₀ ^ α ₁ ) [ o , l ) = = > α ₀ [ o , | α ₀ | - o ) ^ α ₁ [ 0 , l - ( | α ₀ | - o ) )
*
* ⟨ .. . ⟩ ^ ⟨ .. . ⟩
* [ , )
* | α ₀ | ≤ o : ( α ₀ ^ α ₁ ) [ o , l ) = = > α ₀ [ o , 0 ) ^ α ₁ [ o - | α ₀ | , l )
*
* So in general :
*
* ( α ₀ ^ α ₁ ) [ o , l ) = = > α ₀ [ o , l ₀ ) ^ α ₁ [ o ₁ , l - l ₀ )
* where l ₀ = max 0 ( min l | α ₀ | - o )
* o ₁ = max 0 o - | α ₀ |
* )
| Concat na1N -> (
match len with
| Z l ->
Array . fold_map_until na1N ( l , off )
~ f : ( fun naI ( l , oI ) ->
if Z . equal Z . zero l then
` Continue ( _ Extract ~ seq : naI ~ off : oI ~ len : zero , ( l , oI ) )
else
let nI = seq_size_exn naI in
let oI_nI = sub oI nI in
match oI_nI with
| Z z ->
let oJ = if Z . sign z < = 0 then zero else oI_nI in
let lI = Z . ( max zero ( min l ( neg z ) ) ) in
let l = Z . ( l - lI ) in
` Continue
( _ Extract ~ seq : naI ~ off : oI ~ len : ( _ Z lI ) , ( l , oJ ) )
| _ -> ` Stop ( Extract { seq ; off ; len } ) )
~ finish : ( fun ( e1N , _ ) -> _ Concat e1N )
| _ -> Extract { seq ; off ; len } )
(* α ) *)
| _ -> Extract { seq ; off ; len } )
| > check invariant
and _ Concat xs =
let invariant e =
[ % trace ]
let @ () = Invariant . invariant [ % here ] e [ % sexp_of : t ] in
~ call : ( fun { pf } -> pf " @ %a " pp ( Concat xs ) )
match e with
~ retn : ( fun { pf } -> pf " %a " pp )
| Q q -> assert ( not ( Z . equal Z . one ( Q . den q ) ) )
@@ fun () ->
| Arith a -> (
(* ( α ( β^γ ) ^δ ) ==> ( α γ ) *)
match Arith0 . classify a with
let flatten xs =
| Trm _ | Const _ -> assert false
if Array . exists ~ f : ( function Concat _ -> true | _ -> false ) xs then
| _ -> () )
Array . flat_map ~ f : ( function Concat s -> s | e -> [| e |] ) xs
| _ -> ()
else xs
in
let simp_adjacent e f =
match ( e , f ) with
(* ⟨n,a⟩[o,k ) ^⟨n,a⟩[o+k,l ) ==> ⟨n,a⟩[o,k+l ) when n ≥ o+k+l *)
| ( Extract { seq = Sized { siz = n } as na ; off = o ; len = k }
, Extract { seq = na' ; off = o_k ; len = l } )
when equal na na' && equal o_k ( add o k ) && partial_ge n ( add o_k l )
->
Some ( _ Extract ~ seq : na ~ off : o ~ len : ( add k l ) )
(* ⟨m,0⟩^⟨n,0⟩ ==> ⟨m+n,0⟩ *)
| Sized { siz = m ; seq = a } , Sized { siz = n ; seq = a' }
when a = = zero && a' = = zero ->
Some ( _ Sized ~ seq : a ~ siz : ( add m n ) )
(* ⟨m,E^⟩^⟨n,E^⟩ ==> ⟨m+n,E^⟩ *)
| Sized { siz = m ; seq = Splat _ as a } , Sized { siz = n ; seq = a' }
when equal a a' ->
Some ( _ Sized ~ seq : a ~ siz : ( add m n ) )
| _ -> None
in
let xs = flatten xs in
let xs = Array . reduce_adjacent ~ f : simp_adjacent xs in
( if Array . length xs = 1 then xs . ( 0 ) else Concat xs ) | > check invariant
let _ Apply f es =
( match Funsym . eval ~ equal ~ get_z ~ ret_z : _ Z ~ get_q ~ ret_q : _ Q f es with
| Some c -> c
| None -> Apply ( f , es ) )
| > check invariant
(* * Traverse *)
(* * Traverse *)
let rec iter_vars e ~ f =
let rec iter_vars e ~ f =
match e with
match e with
| Var _ as v -> f ( Var 1 . of_ v )
| Var _ as v -> f ( Var . of_ v )
| Z _ | Q _ -> ()
| Z _ | Q _ -> ()
| Splat x -> iter_vars ~ f x
| Splat x -> iter_vars ~ f x
| Sized { seq = x ; siz = y } ->
| Sized { seq = x ; siz = y } ->
@ -416,33 +203,55 @@ end = struct
iter_vars ~ f y ;
iter_vars ~ f y ;
iter_vars ~ f z
iter_vars ~ f z
| Concat xs | Apply ( _ , xs ) -> Array . iter ~ f : ( iter_vars ~ f ) xs
| Concat xs | Apply ( _ , xs ) -> Array . iter ~ f : ( iter_vars ~ f ) xs
| Arith a -> Iter . iter ~ f : ( iter_vars ~ f ) ( Arith . trms a )
| Arith a -> Iter . iter ~ f : ( iter_vars ~ f ) ( Arith 0 . trms a )
let vars e = Iter . from_labelled_iter ( iter_vars e )
let vars e = Iter . from_labelled_iter ( iter_vars e )
(* * Construct *)
(* statically allocated since they are tested with == *)
let zero = Z Z . zero | > check invariant
let one = Z Z . one | > check invariant
let _ Z z =
( if Z . equal Z . zero z then zero else if Z . equal Z . one z then one else Z z )
| > check invariant
let _ Q q =
( if Z . equal Z . one ( Q . den q ) then _ Z ( Q . num q ) else Q q )
| > check invariant
let _ Arith a =
( match Arith0 . classify a with
| Trm e -> e
| Const q -> _ Q q
| _ -> Arith a )
| > check invariant
end end
include Trm include Trm
module Var = Var1
module Set = struct (* Instantiate arithmetic with embedding into terms, yielding full
include Set . Make ( Trm )
Arithmetic interface * )
include Provide_of_sexp ( Trm )
module Arith =
include Provide_pp ( Trm )
Arith0 . Embed ( Var ) ( Trm )
( struct
let of_vars : Var . Set . t -> t =
let to_trm = _ Arith
fun vs ->
of_iter
let get_arith e =
( Iter . map ~ f : ( fun v -> ( v : Var . t :> Trm . t ) ) ( Var . Set . to_iter vs ) )
match e with
end | Z z -> Some ( Arith0 . const ( Q . of_z z ) )
| Q q -> Some ( Arith0 . const q )
| Arith a -> Some a
| _ -> None
end )
module Map = struct (* Full Trm definition, using full arithmetic interface *)
include Map . Make ( Trm )
include Provide_of_sexp ( Trm )
end
type arith = Arith . t (* * Destruct *)
let pp_diff fs ( x , y ) = Format . fprintf fs " -- %a ++ %a " pp x pp y let get_z = function Z z -> Some z | _ -> None
let get_q = function Q q -> Some q | Z z -> Some ( Q . of_z z ) | _ -> None
(* * Construct *) (* * Construct *)
@ -452,13 +261,11 @@ let var v = (v : Var.t :> t)
(* arithmetic *) (* arithmetic *)
let zero = _ Z Z . zero
let one = _ Z Z . one
let integer z = _ Z z let integer z = _ Z z
let rational q = _ Q q let rational q = _ Q q
let neg x = _ Arith Arith . ( neg ( trm x ) ) let neg x = _ Arith Arith . ( neg ( trm x ) )
let add = Trm . add let add x y = _ Arith Arith . ( add ( trm x ) ( trm y ) )
let sub = Trm . sub let sub x y = _ Arith Arith . ( sub ( trm x ) ( trm y ) )
let mulq q x = _ Arith Arith . ( mulc q ( trm x ) ) let mulq q x = _ Arith Arith . ( mulc q ( trm x ) )
let mul x y = _ Arith ( Arith . mul x y ) let mul x y = _ Arith ( Arith . mul x y )
let div x y = _ Arith ( Arith . div x y ) let div x y = _ Arith ( Arith . div x y )
@ -467,14 +274,145 @@ let arith = _Arith
(* sequences *) (* sequences *)
let splat = _ Splat let splat x =
let sized = _ Sized (* 0^ ==> 0 *)
let extract = _ Extract ( if x = = zero then x else Splat x ) | > check invariant
let concat elts = _ Concat elts
let seq_size_exn =
let invalid = Invalid_argument " seq_size_exn " in
let rec seq_size_exn = function
| Sized { siz = n } | Extract { len = n } -> n
| Concat a0U ->
Array . fold ~ f : ( fun aJ a0I -> add a0I ( seq_size_exn aJ ) ) a0U zero
| _ -> raise invalid
in
seq_size_exn
let seq_size e = try Some ( seq_size_exn e ) with Invalid_argument _ -> None
let sized ~ seq ~ siz =
( match seq_size seq with
(* ⟨n,α⟩ ==> α α *)
| Some n when equal siz n -> seq
| _ -> Sized { seq ; siz } )
| > check invariant
let partial_compare x y =
match sub x y with
| Z z -> Some ( Int . sign ( Z . sign z ) )
| Q q -> Some ( Int . sign ( Q . sign q ) )
| _ -> None
let partial_ge x y =
match partial_compare x y with Some ( Pos | Zero ) -> true | _ -> false
let empty_seq = Concat [| |]
let rec extract ~ seq ~ off ~ len =
[ % trace ]
~ call : ( fun { pf } -> pf " @ %a " pp ( Extract { seq ; off ; len } ) )
~ retn : ( fun { pf } -> pf " %a " pp )
@@ fun () ->
(* _[_,0 ) ==> ⟨⟩ *)
( if equal len zero then empty_seq
else
let o_l = add off len in
match seq with
(* α ) [o,l ) ==> α ) when k ≥ o+l *)
| Extract { seq = a ; off = m ; len = k } when partial_ge k o_l ->
extract ~ seq : a ~ off : ( add m off ) ~ len
(* ⟨n,0⟩[o,l ) ==> ⟨l,0⟩ when n ≥ o+l *)
| Sized { siz = n ; seq } when seq = = zero && partial_ge n o_l ->
sized ~ seq ~ siz : len
(* ⟨n,E^⟩[o,l ) ==> ⟨l,E^⟩ when n ≥ o+l *)
| Sized { siz = n ; seq = Splat _ as e } when partial_ge n o_l ->
sized ~ seq : e ~ siz : len
(* ⟨n,a⟩[0,n ) ==> ⟨n,a⟩ *)
| Sized { siz = n } when equal off zero && equal n len -> seq
(* For ( α₀^α₁ ) [o,l ) there are 3 cases:
*
* ⟨ .. . ⟩ ^ ⟨ .. . ⟩
* [ , )
* o < o + l ≤ | α ₀ | : ( α ₀ ^ α ₁ ) [ o , l ) = = > α ₀ [ o , l ) ^ α ₁ [ 0 , 0 )
*
* ⟨ .. . ⟩ ^ ⟨ .. . ⟩
* [ , )
* o ≤ | α ₀ | < o + l : ( α ₀ ^ α ₁ ) [ o , l ) = = > α ₀ [ o , | α ₀ | - o ) ^ α ₁ [ 0 , l - ( | α ₀ | - o ) )
*
* ⟨ .. . ⟩ ^ ⟨ .. . ⟩
* [ , )
* | α ₀ | ≤ o : ( α ₀ ^ α ₁ ) [ o , l ) = = > α ₀ [ o , 0 ) ^ α ₁ [ o - | α ₀ | , l )
*
* So in general :
*
* ( α ₀ ^ α ₁ ) [ o , l ) = = > α ₀ [ o , l ₀ ) ^ α ₁ [ o ₁ , l - l ₀ )
* where l ₀ = max 0 ( min l | α ₀ | - o )
* o ₁ = max 0 o - | α ₀ |
* )
| Concat na1N -> (
match len with
| Z l ->
Array . fold_map_until na1N ( l , off )
~ f : ( fun naI ( l , oI ) ->
if Z . equal Z . zero l then
` Continue ( extract ~ seq : naI ~ off : oI ~ len : zero , ( l , oI ) )
else
let nI = seq_size_exn naI in
let oI_nI = sub oI nI in
match oI_nI with
| Z z ->
let oJ = if Z . sign z < = 0 then zero else oI_nI in
let lI = Z . ( max zero ( min l ( neg z ) ) ) in
let l = Z . ( l - lI ) in
` Continue
( extract ~ seq : naI ~ off : oI ~ len : ( _ Z lI ) , ( l , oJ ) )
| _ -> ` Stop ( Extract { seq ; off ; len } ) )
~ finish : ( fun ( e1N , _ ) -> concat e1N )
| _ -> Extract { seq ; off ; len } )
(* α ) *)
| _ -> Extract { seq ; off ; len } )
| > check invariant
and concat xs =
[ % trace ]
~ call : ( fun { pf } -> pf " @ %a " pp ( Concat xs ) )
~ retn : ( fun { pf } -> pf " %a " pp )
@@ fun () ->
(* ( α ( β^γ ) ^δ ) ==> ( α γ ) *)
let flatten xs =
if Array . exists ~ f : ( function Concat _ -> true | _ -> false ) xs then
Array . flat_map ~ f : ( function Concat s -> s | e -> [| e |] ) xs
else xs
in
let simp_adjacent e f =
match ( e , f ) with
(* ⟨n,a⟩[o,k ) ^⟨n,a⟩[o+k,l ) ==> ⟨n,a⟩[o,k+l ) when n ≥ o+k+l *)
| ( Extract { seq = Sized { siz = n } as na ; off = o ; len = k }
, Extract { seq = na' ; off = o_k ; len = l } )
when equal na na' && equal o_k ( add o k ) && partial_ge n ( add o_k l )
->
Some ( extract ~ seq : na ~ off : o ~ len : ( add k l ) )
(* ⟨m,0⟩^⟨n,0⟩ ==> ⟨m+n,0⟩ *)
| Sized { siz = m ; seq = a } , Sized { siz = n ; seq = a' }
when a = = zero && a' = = zero ->
Some ( sized ~ seq : a ~ siz : ( add m n ) )
(* ⟨m,E^⟩^⟨n,E^⟩ ==> ⟨m+n,E^⟩ *)
| Sized { siz = m ; seq = Splat _ as a } , Sized { siz = n ; seq = a' }
when equal a a' ->
Some ( sized ~ seq : a ~ siz : ( add m n ) )
| _ -> None
in
let xs = flatten xs in
let xs = Array . reduce_adjacent ~ f : simp_adjacent xs in
( if Array . length xs = 1 then xs . ( 0 ) else Concat xs ) | > check invariant
(* uninterpreted *) (* uninterpreted *)
let apply sym args = _ Apply sym args let apply f es =
( match Funsym . eval ~ equal ~ get_z ~ ret_z : _ Z ~ get_q ~ ret_q : _ Q f es with
| Some c -> c
| None -> Apply ( f , es ) )
| > check invariant
(* * Traverse *) (* * Traverse *)
@ -505,25 +443,25 @@ let rec map_vars e ~f =
| Var _ as v -> ( f ( Var . of_ v ) : Var . t :> t )
| Var _ as v -> ( f ( Var . of_ v ) : Var . t :> t )
| Z _ | Q _ -> e
| Z _ | Q _ -> e
| Arith a -> map1 ( Arith . map ~ f : ( map_vars ~ f ) ) e _ Arith a
| Arith a -> map1 ( Arith . map ~ f : ( map_vars ~ f ) ) e _ Arith a
| Splat x -> map1 ( map_vars ~ f ) e _ S x
| Splat x -> map1 ( map_vars ~ f ) e s x
| Sized { seq ; siz } ->
| Sized { seq ; siz } ->
map2 ( map_vars ~ f ) e ( fun seq siz -> _ S ~ seq ~ siz ) seq siz
map2 ( map_vars ~ f ) e ( fun seq siz -> s ~ seq ~ siz ) seq siz
| Extract { seq ; off ; len } ->
| Extract { seq ; off ; len } ->
map3 ( map_vars ~ f ) e
map3 ( map_vars ~ f ) e
( fun seq off len -> _ E ~ seq ~ off ~ len )
( fun seq off len -> e ~ seq ~ off ~ len )
seq off len
seq off len
| Concat xs -> mapN ( map_vars ~ f ) e _ C xs
| Concat xs -> mapN ( map_vars ~ f ) e c xs
| Apply ( g , xs ) -> mapN ( map_vars ~ f ) e ( _ A g ) xs
| Apply ( g , xs ) -> mapN ( map_vars ~ f ) e ( a g ) xs
let map e ~ f = let map e ~ f =
match e with
match e with
| Var _ | Z _ | Q _ -> e
| Var _ | Z _ | Q _ -> e
| Arith a -> map1 ( Arith . map ~ f ) e _ Arith a
| Arith a -> map1 ( Arith . map ~ f ) e _ Arith a
| Splat x -> map1 f e _ S x
| Splat x -> map1 f e s x
| Sized { seq ; siz } -> map2 f e ( fun seq siz -> _ S ~ seq ~ siz ) seq siz
| Sized { seq ; siz } -> map2 f e ( fun seq siz -> s ~ seq ~ siz ) seq siz
| Extract { seq ; off ; len } ->
| Extract { seq ; off ; len } ->
map3 f e ( fun seq off len -> _ E ~ seq ~ off ~ len ) seq off len
map3 f e ( fun seq off len -> e ~ seq ~ off ~ len ) seq off len
| Concat xs -> mapN f e _ C xs
| Concat xs -> mapN f e c xs
| Apply ( g , xs ) -> mapN f e ( _ A g ) xs
| Apply ( g , xs ) -> mapN f e ( a g ) xs
let fold_map e = fold_map_from_map map e let fold_map e = fold_map_from_map map e
Josh Berdine
4 years ago
committed by
Facebook GitHub Bot