QCaml/ci/lib/spindeterminant.ml

open Common

type s =
  {
    bitstring : Bitstring.t;
    phase     : Phase.t ;
  }

type t = s option
type hole = int
type particle = int

let phase = function
  | Some s -> s.phase
  | None -> Phase.Pos


let is_none = function
  | None -> true
  | _ -> false


let bitstring = function
  | Some s -> s.bitstring
  | None -> invalid_arg "Spindeterminant is None"


let vac n =
  Some  { bitstring = Bitstring.zero n;
          phase     = Phase.Pos; }


let creation p = function
  | None -> None
  | Some spindet ->
    let i = pred p in
    if Bitstring.testbit spindet.bitstring i then
      None
    else
      begin
        let numbits = Bitstring.numbits spindet.bitstring in
        let x = Bitstring.shift_left_one numbits i in
        let bitstring = Bitstring.logor spindet.bitstring x in
        let mask = Bitstring.minus_one x in
        let r = Bitstring.logand bitstring mask in
        let phase = Phase.add_nperm spindet.phase (Bitstring.popcount r) in
        Some { bitstring ; phase }
      end


let annihilation h = function
  | None -> None
  | Some spindet ->
    let i = pred h in
    if not (Bitstring.testbit spindet.bitstring i) then
      None
    else
      begin
        let numbits = Bitstring.numbits spindet.bitstring in
        let x = Bitstring.shift_left_one numbits i in
        let mask = Bitstring.minus_one x in
        let r = Bitstring.logand spindet.bitstring mask in
        let phase = Phase.add_nperm spindet.phase (Bitstring.popcount r) in
        let bitstring = Bitstring.logand spindet.bitstring (Bitstring.lognot x) in
        Some { bitstring ; phase }
      end

let single_excitation_reference h p spindet =
      creation p @@ annihilation h @@ spindet

let single_excitation h p =
  single_excitation_reference h p


let double_excitation_reference h' p' h p spindet =
      creation p' @@ creation p @@ annihilation h @@ annihilation h' @@ spindet

let double_excitation h' p' h p =
  double_excitation_reference h' p' h p


let excitation_level t t' =
  Bitstring.hamdist (bitstring t) (bitstring t') / 2

let holes_of t t' =
  Bitstring.logand (bitstring t) (Bitstring.logxor (bitstring t) (bitstring t'))
  |> Bitstring.to_list

let particles_of t t' =
  Bitstring.logand (bitstring t') (Bitstring.logxor (bitstring t) (bitstring t'))
  |> Bitstring.to_list

let holes_particles_of t t' =
  let x = Bitstring.logxor (bitstring t) (bitstring t') in
  let holes = Bitstring.logand (bitstring t) x |> Bitstring.to_list
  and particles = Bitstring.logand (bitstring t') x |> Bitstring.to_list
  in
  List.rev_map2 (fun h p -> (h,p)) holes particles
  |> List.rev


let set_phase p = function
  | Some t -> Some { t with phase = p }
  | None -> None

let negate_phase = function
  | Some t -> Some { t with phase = Phase.neg t.phase }
  | None -> None


let of_bitstring ?(phase=Phase.Pos) bitstring =
  Some { bitstring ; phase }

let of_list n l =
  List.rev l
  |> List.fold_left (fun accu p -> creation p accu) (vac n)


let to_list = function
  | None -> []
  | Some spindet ->
    let rec aux accu z =
      if not (Bitstring.is_zero z) then
        let element = ((Bitstring.trailing_zeros z)+1) in
        (aux [@tailcall]) (element::accu) (Bitstring.logand z (Bitstring.minus_one z) )
      else List.rev accu
    in aux [] spindet.bitstring

let to_array t =
  to_list t
  |> Array.of_list

let n_electrons = function
  | Some t -> Bitstring.popcount t.bitstring
  | None -> 0


let pp ppf = function
  | None -> Format.fprintf ppf "@[<h>None@]"
  | Some s ->
      Format.fprintf ppf "@[<h>%a %a@]" Phase.pp s.phase Bitstring.pp
      s.bitstring