# ============================================================================
# CLDedgelister - model importers
# ----------------------------------------------------------------------------
# Convert Vensim / Stella / Powersim / AnyLogic / GoldSim models into a
# two-column edge list: INPUT (cause) -> OUTPUT (effect).
# ============================================================================

# --- shared helpers ---------------------------------------------------------

.clean_name <- function(x) {
  if (is.null(x) || length(x) == 0) return("")
  x <- gsub("\\\\", " ", x)          # line continuations
  x <- trimws(x)
  x <- gsub('^"|"$', "", x)          # surrounding quotes
  # strip ghost/shadow brackets <Var>
  x <- sub("^<(.*)>$", "\\1", x)
  x <- gsub("[[:space:]]+", " ", x)  # collapse whitespace/newlines
  trimws(x)
}

.control_vars <- c("FINAL TIME", "INITIAL TIME", "SAVEPER", "TIME STEP",
                   "Time")

.legend_anchors <- c(".", "KEY")

# Vensim quotes any variable name containing a comma, parenthesis or hyphen,
# e.g.  "Climate (Temp, rainfall, etc.)".  Argument lists must therefore be
# split on commas that are OUTSIDE quotes only.
#
# The obvious pattern '"[^"]*"|[^,]+' does NOT work: Vensim writes a space
# after the opening parenthesis, so the argument string starts with a space,
# the quoted branch cannot match at position 1, and the '[^,]+' branch fires
# instead -- greedily swallowing the opening quote along with everything up to
# the first comma.  The quoted name is then torn into three fake variables.
#
# '(?:"[^"]*"|[^,])+' retries the quoted branch at EVERY character, so an
# opening quote is always absorbed together with its closing quote and the
# commas between them.  It needs perl = TRUE: R's default TRE engine does not
# support non-capturing groups.
.arg_token_re <- '(?:"[^"]*"|[^,])+'

.split_arguments <- function(arg_text) {
  if (is.null(arg_text) || is.na(arg_text) || !nzchar(arg_text))
    return(character(0))
  toks <- regmatches(arg_text,
                     gregexpr(.arg_token_re, arg_text, perl = TRUE))[[1]]
  out <- character(0)
  for (t in toks) {
    t <- .clean_name(sub("^[+-]", "", trimws(t)))
    if (nzchar(t)) out <- c(out, t)
  }
  out
}

# Modellers draw the KEY of a diagram with dummy variables labelled using
# punctuation only -- ".", "..", ",", ",,", ",,," and so on (Vensim renders
# them in white so they disappear).  Matching on a fixed list missed every
# variant except ".", so those legend arrows leaked into the edge list.  Any
# label with no letters or digits in it is one of these.
.is_legend_anchor <- function(name, anchors = .legend_anchors) {
  if (is.null(name) || is.na(name) || !nzchar(name)) return(FALSE)
  if (name %in% anchors) return(TRUE)
  !grepl("[[:alnum:]]", name)
}

# Escape every PCRE metacharacter so a variable name is matched literally.
# R has no built-in regex-quote; the class below lists ']' first and '-' last,
# which is the portable way to include them without a range being inferred.
.regex_escape <- function(x) {
  gsub("([][{}()*+?.\\\\^$|#-])", "\\\\\\1", x, perl = TRUE)
}

# Match `var` as a standalone identifier, quoted or bare.  Vensim writes
# punctuated names in quotes inside full equations, so the boundary test has
# to allow an optional surrounding quote character.
.name_pattern <- function(var) {
  paste0("(?<![A-Za-z0-9_])\"?", .regex_escape(var), "\"?(?![A-Za-z0-9_])")
}

.xmile_funcs <- c(
  "if", "then", "else", "and", "or", "not", "min", "max", "abs", "exp",
  "ln", "log10", "sqrt", "sin", "cos", "tan", "int", "round", "pulse",
  "step", "ramp", "dt", "time", "starttime", "stoptime", "pi",
  "smth1", "smth3", "smthn", "delay", "delay1", "delay3", "delayn",
  "init", "previous", "mean", "sum", "stddev", "normal", "random",
  "poisson", "exprnd", "history")

# pull candidate identifiers out of an equation string
.identifiers <- function(expr) {
  if (is.null(expr) || is.na(expr) || !nzchar(expr)) return(character(0))
  quoted <- regmatches(expr, gregexpr('"([^"]+)"', expr))[[1]]
  quoted <- gsub('"', "", quoted)
  bare <- regmatches(expr, gregexpr("[A-Za-z_][A-Za-z0-9_ ]*", expr))[[1]]
  toks <- c(quoted, trimws(bare))
  toks[nzchar(toks)]
}

.new_edge_df <- function(edges) {
  if (length(edges) == 0)
    return(data.frame(INPUT = character(0), OUTPUT = character(0),
                      stringsAsFactors = FALSE))
  m <- do.call(rbind, edges)
  df <- data.frame(INPUT = m[, 1], OUTPUT = m[, 2],
                   stringsAsFactors = FALSE)
  unique(df)
}

# Remove diagram legend/KEY edges: any variable whose only connections are to
# the anchor labels "." / "KEY".
.drop_legend_edges <- function(df, anchors = .legend_anchors) {
  if (nrow(df) == 0) return(df)
  all_nodes <- unique(c(df$INPUT, df$OUTPUT))
  anchor_nodes <- all_nodes[vapply(all_nodes, .is_legend_anchor,
                                   logical(1), anchors = anchors)]
  partners <- list()
  add <- function(a, b) {
    partners[[a]] <<- unique(c(partners[[a]], b))
  }
  for (i in seq_len(nrow(df))) {
    add(df$INPUT[i], df$OUTPUT[i])
    add(df$OUTPUT[i], df$INPUT[i])
  }
  # a variable whose ONLY neighbours are anchors (e.g. a "Delay Mark" label
  # attached to the key) belongs to the legend too
  legend_only <- names(partners)[vapply(names(partners), function(v) {
    if (v %in% anchor_nodes) return(FALSE)
    ps <- partners[[v]]
    length(ps) > 0 && all(ps %in% anchor_nodes)
  }, logical(1))]
  excluded <- unique(c(anchor_nodes, legend_only))
  df[!(df$INPUT %in% excluded | df$OUTPUT %in% excluded), , drop = FALSE]
}

# ============================================================================
# 1) Vensim  (.mdl / .2mdl)
# ============================================================================

parse_vensim <- function(path) {
  txt <- readLines(path, warn = FALSE, encoding = "UTF-8")
  full <- paste(txt, collapse = "\n")

  # split sketch from equations
  sketch_start <- regexpr("\\\\---///", full)
  if (sketch_start > 0) {
    eq_text <- substr(full, 1, sketch_start - 1)
    sketch_text <- substr(full, sketch_start, nchar(full))
  } else {
    eq_text <- full
    sketch_text <- ""
  }

  edges <- list()
  positions <- list()

  # ---- sketch parsing (preferred: preserves drawing order) ----
  if (nzchar(sketch_text)) {
    lines <- strsplit(sketch_text, "\n")[[1]]
    id_to_name <- list()
    arrows <- list()

    flush <- function() {
      for (a in arrows) {
        src <- id_to_name[[as.character(a[1])]]
        dst <- id_to_name[[as.character(a[2])]]
        if (!is.null(src) && !is.null(dst) &&
            !(src %in% .control_vars) && !(dst %in% .control_vars)) {
          edges[[length(edges) + 1]] <<- c(src, dst)
        }
      }
    }

    for (ln in lines) {
      ln <- trimws(ln)
      if (startsWith(ln, "*")) {          # new view -> reset ids
        flush(); id_to_name <- list(); arrows <- list(); next
      }
      # variable definition: 10,ID,Name,x,y,...
      m <- regmatches(ln, regexec("^(10|11|12),(\\d+),(.*)$", ln))[[1]]
      if (length(m) == 4) {
        etype <- m[2]; eid <- m[3]; rest <- m[4]
        if (startsWith(rest, "\"")) {
          nm <- regmatches(rest, regexec('^"((?:[^"\\\\]|\\\\.)*)"',
                                         rest))[[1]]
          name <- if (length(nm) >= 2) nm[2] else ""
          after <- sub('^"((?:[^"\\\\]|\\\\.)*)"', "", rest)
        } else {
          name <- strsplit(rest, ",")[[1]][1]
          after <- sub("^[^,]*", "", rest)
        }
        name <- .clean_name(name)
        if (etype == "10" && nzchar(name)) {
          id_to_name[[eid]] <- name
          nums <- suppressWarnings(as.numeric(
            strsplit(gsub("^,", "", after), ",")[[1]]))
          nums <- nums[!is.na(nums)]
          if (length(nums) >= 2) positions[[name]] <- c(nums[1], nums[2])
        }
        next
      }
      # arrow: 1,ArrowID,FromID,ToID,...
      m <- regmatches(ln, regexec("^1,(\\d+),(\\d+),(\\d+),", ln))[[1]]
      if (length(m) == 4)
        arrows[[length(arrows) + 1]] <- c(as.integer(m[3]),
                                          as.integer(m[4]))
    }
    flush()
  }

  # ---- equation fallback / supplement ----
  eq_edges <- .vensim_equation_edges(eq_text)
  df <- .new_edge_df(edges)
  if (nrow(df) == 0) {
    df <- eq_edges
  } else if (nrow(eq_edges) > 0) {
    # add any equation-only edges the sketch missed
    key <- paste(df$INPUT, df$OUTPUT, sep = "\r")
    ekey <- paste(eq_edges$INPUT, eq_edges$OUTPUT, sep = "\r")
    add <- eq_edges[!(ekey %in% key), , drop = FALSE]
    df <- rbind(df, add)
  }
  df <- .drop_legend_edges(df)
  attr(df, "positions") <- positions
  df
}

.vensim_equation_edges <- function(eq_text) {
  eq_text <- sub("^\\{UTF-8\\}", "", trimws(eq_text))
  chunks <- strsplit(eq_text, "\\|")[[1]]
  eqs <- list()
  for (chunk in chunks) {
    eq_part <- strsplit(chunk, "~")[[1]][1]
    if (is.na(eq_part) || !grepl("=", eq_part)) next
    sides <- strsplit(eq_part, "=", fixed = TRUE)[[1]]
    if (length(sides) < 2) next
    out_var <- .clean_name(sides[1])
    rhs <- paste(sides[-1], collapse = "=")
    if (!nzchar(out_var) || out_var %in% .control_vars ||
        .is_legend_anchor(out_var)) next
    m <- regmatches(rhs, regexec(
      "A\\s+FUNCTION\\s+OF\\s*\\((.*)\\)", rhs, ignore.case = TRUE))[[1]]
    if (length(m) >= 2) {
      # split on commas OUTSIDE quotes, so "Climate (Temp, rainfall, etc.)"
      # survives as ONE variable instead of three
      eqs[[length(eqs) + 1]] <- list(out = out_var,
                                     inputs = .split_arguments(m[2]),
                                     raw = NA_character_)
    } else {
      # a real equation rather than the "A FUNCTION OF(...)" shorthand;
      # resolve the names it mentions on a second pass, once every variable
      # in the model is known
      eqs[[length(eqs) + 1]] <- list(out = out_var, inputs = NULL,
                                     raw = rhs)
    }
  }

  # ---- second pass: resolve full equations against the known variables ----
  all_vars <- vapply(eqs, function(e) e$out, character(1))
  by_length <- all_vars[order(nchar(all_vars), decreasing = TRUE)]
  for (i in seq_along(eqs)) {
    if (is.na(eqs[[i]]$raw)) next
    taken <- gsub("\\\\", " ", eqs[[i]]$raw)
    found <- character(0)
    for (v in by_length) {
      pat <- .name_pattern(v)
      if (grepl(pat, taken, perl = TRUE)) {
        found <- c(found, v)
        taken <- gsub(pat, " ", taken, perl = TRUE)
      }
    }
    # keep the order the names appear in the original equation
    if (length(found)) {
      pos <- vapply(found, function(v)
        regexpr(v, eqs[[i]]$raw, fixed = TRUE)[1], numeric(1))
      found <- found[order(pos)]
    }
    eqs[[i]]$inputs <- found
  }

  edges <- list()
  for (e in eqs)
    for (inp in e$inputs)
      if (nzchar(inp) && inp != e$out && !(inp %in% .control_vars))
        edges[[length(edges) + 1]] <- c(inp, e$out)
  .new_edge_df(edges)
}

# ============================================================================
# 2) XMILE  (Stella / iThink / Powersim export)
# ============================================================================

parse_xmile <- function(path) {
  doc <- xml2::read_xml(path)
  xml2::xml_ns_strip(doc)

  equations <- list()
  struct <- list()
  positions <- list()

  var_nodes <- xml2::xml_find_all(doc, ".//stock | .//flow | .//aux | .//gf")
  for (nd in var_nodes) {
    name <- .clean_name(xml2::xml_attr(nd, "name"))
    if (!nzchar(name)) next
    eqn <- xml2::xml_text(xml2::xml_find_first(nd, "./eqn"))
    equations[[name]] <- if (is.na(eqn)) "" else eqn
    for (inflow in xml2::xml_find_all(nd, "./inflow")) {
      f <- .clean_name(xml2::xml_text(inflow))
      if (nzchar(f)) struct[[length(struct) + 1]] <- c(f, name)
    }
    for (outflow in xml2::xml_find_all(nd, "./outflow")) {
      f <- .clean_name(xml2::xml_text(outflow))
      if (nzchar(f)) struct[[length(struct) + 1]] <- c(name, f)
    }
  }

  # positions from <views>
  for (nd in xml2::xml_find_all(doc, ".//*[@x and @y]")) {
    nm <- .clean_name(xml2::xml_attr(nd, "name"))
    x <- suppressWarnings(as.numeric(xml2::xml_attr(nd, "x")))
    y <- suppressWarnings(as.numeric(xml2::xml_attr(nd, "y")))
    if (nzchar(nm) && !is.na(x) && !is.na(y)) positions[[nm]] <- c(x, y)
  }

  var_names <- names(equations)
  lower_map <- setNames(var_names, tolower(var_names))
  edges <- list()
  add_edge <- function(s, d) {
    if (nzchar(s) && nzchar(d) && s != d)
      edges[[length(edges) + 1]] <<- c(s, d)
  }
  for (name in names(equations)) {
    for (tok in .identifiers(equations[[name]])) {
      key <- tolower(trimws(tok))
      if (key %in% .xmile_funcs) next
      if (!is.na(lower_map[key])) add_edge(unname(lower_map[key]), name)
    }
  }
  for (s in struct) {
    a <- if (!is.na(lower_map[tolower(s[1])])) unname(lower_map[tolower(s[1])]) else s[1]
    b <- if (!is.na(lower_map[tolower(s[2])])) unname(lower_map[tolower(s[2])]) else s[2]
    add_edge(a, b)
  }
  df <- .new_edge_df(edges)
  attr(df, "positions") <- positions
  df
}

# ============================================================================
# 3) AnyLogic  (.alp project XML)
# ============================================================================

parse_anylogic <- function(path) {
  doc <- xml2::read_xml(path)
  xml2::xml_ns_strip(doc)

  equations <- list()
  names_by_id <- list()
  positions <- list()
  connectors <- list()

  sd_nodes <- xml2::xml_find_all(
    doc, ".//Stock | .//Flow | .//DynamicVariable | .//Parameter")
  for (nd in sd_nodes) {
    name <- .clean_name(xml2::xml_text(xml2::xml_find_first(nd, "./Name")))
    eid <- xml2::xml_attr(nd, "Id")
    formula <- ""
    for (tag in c("Formula", "InitialValue", "Equation")) {
      v <- xml2::xml_text(xml2::xml_find_first(nd, paste0("./", tag)))
      if (!is.na(v)) formula <- paste(formula, v)
    }
    if (nzchar(name)) {
      if (!is.na(eid)) names_by_id[[eid]] <- name
      equations[[name]] <- formula
      x <- suppressWarnings(as.numeric(xml2::xml_attr(nd, "X")))
      y <- suppressWarnings(as.numeric(xml2::xml_attr(nd, "Y")))
      if (!is.na(x) && !is.na(y)) positions[[name]] <- c(x, y)
    }
  }
  for (nd in xml2::xml_find_all(doc, ".//Connector")) {
    s <- xml2::xml_attr(nd, "Source"); d <- xml2::xml_attr(nd, "Target")
    if (!is.na(s) && !is.na(d)) connectors[[length(connectors) + 1]] <- c(s, d)
  }

  var_names <- names(equations)
  lower_map <- setNames(var_names, tolower(var_names))
  edges <- list()
  add_edge <- function(s, d) {
    if (nzchar(s) && nzchar(d) && s != d)
      edges[[length(edges) + 1]] <<- c(s, d)
  }
  for (name in names(equations)) {
    for (tok in .identifiers(equations[[name]])) {
      key <- tolower(trimws(tok))
      if (key %in% .xmile_funcs) next
      if (!is.na(lower_map[key]) && unname(lower_map[key]) != name)
        add_edge(unname(lower_map[key]), name)
    }
  }
  for (c in connectors) {
    s <- if (!is.null(names_by_id[[c[1]]])) names_by_id[[c[1]]] else c[1]
    d <- if (!is.null(names_by_id[[c[2]]])) names_by_id[[c[2]]] else c[2]
    add_edge(.clean_name(s), .clean_name(d))
  }
  df <- .new_edge_df(edges)
  attr(df, "positions") <- positions
  df
}

# ============================================================================
# 4) GoldSim  (exported .xml)
# ============================================================================

parse_goldsim <- function(path) {
  doc <- xml2::read_xml(path)
  xml2::xml_ns_strip(doc)

  equations <- list()
  names_by_id <- list()
  positions <- list()

  nodes <- xml2::xml_find_all(doc, ".//element | .//Element | .//node")
  for (nd in nodes) {
    name <- .clean_name(xml2::xml_attr(nd, "Name"))
    if (!nzchar(name)) name <- .clean_name(xml2::xml_attr(nd, "name"))
    eid <- xml2::xml_attr(nd, "ID")
    if (is.na(eid)) eid <- xml2::xml_attr(nd, "id")
    expr <- ""
    inputs <- character(0)
    for (tag in c("equation", "definition", "expression", "formula")) {
      v <- xml2::xml_text(xml2::xml_find_first(nd, paste0("./", tag)))
      if (!is.na(v)) expr <- paste(expr, v)
    }
    for (tag in c("input", "inputs", "reference")) {
      for (ic in xml2::xml_find_all(nd, paste0("./", tag))) {
        tx <- xml2::xml_text(ic)
        if (!is.na(tx) && nzchar(trimws(tx)))
          inputs <- c(inputs, .clean_name(tx))
        for (sub in xml2::xml_children(ic)) {
          st <- xml2::xml_text(sub)
          if (!is.na(st) && nzchar(trimws(st)))
            inputs <- c(inputs, .clean_name(st))
        }
      }
    }
    if (nzchar(name)) {
      if (!is.na(eid)) names_by_id[[eid]] <- name
      equations[[name]] <- list(expr = expr, inputs = inputs)
      x <- suppressWarnings(as.numeric(xml2::xml_attr(nd, "X")))
      y <- suppressWarnings(as.numeric(xml2::xml_attr(nd, "Y")))
      if (!is.na(x) && !is.na(y)) positions[[name]] <- c(x, y)
    }
  }

  var_names <- names(equations)
  lower_map <- setNames(var_names, tolower(var_names))
  edges <- list()
  add_edge <- function(s, d) {
    if (nzchar(s) && nzchar(d) && s != d)
      edges[[length(edges) + 1]] <<- c(s, d)
  }
  for (name in names(equations)) {
    info <- equations[[name]]
    for (tok in info$inputs) {
      key <- tolower(trimws(tok))
      if (!is.na(lower_map[key]) && unname(lower_map[key]) != name) {
        add_edge(unname(lower_map[key]), name)
      } else if (nzchar(tok) && tok != name) {
        add_edge(tok, name)
      }
    }
    for (tok in .identifiers(info$expr)) {
      key <- tolower(trimws(tok))
      if (key %in% .xmile_funcs) next
      if (!is.na(lower_map[key]) && unname(lower_map[key]) != name)
        add_edge(unname(lower_map[key]), name)
    }
  }
  df <- .new_edge_df(edges)
  attr(df, "positions") <- positions
  df
}
