/*
  May 19, 2003, Per Mildner (qpsupport@sics.se)

  Example of a main written in C or C++ that links to QP and vice
  versa and does various calls to Prolog.

  For questions about this contact qpsupport@sics.se

  See the Makefile for instructions on building and running the
  sample. If you have gcc and the Quintus Prolog tools (qld, qpc) in
  your PATH then it should be sufficient to do

    make clean check

  If you want to test the C++ version (which uses the same code) do:
  
    make clean check C_DIALECT=cpp

  The code consists of the main executable myapp.c (this file) which
  can be compiled as either C or C++. It will initialize quintus and
  call into the prolog code testmodule.pl. The prolog code will then
  call back into myapp.c via a stub (myforeign.c).

  The reason the myforeign.c stub is used is so that there is an
  object file that foreign_file/2 and load_foreign_files/2 in
  testmodule.pl can refer to as the source of the foreign predicate
  callback_pred/2. The more common method for defining foreign
  predicates is via a shared object file but that would not as easily
  allow us to call back into the surrounding executable (myapp.c).


  During the build qcon will complain:

   qcon: Undefined: user:runtime_entry/1

  This is not a problem since runtime_entry/1 is only called if you
  call QP_toplevel which this example does not.

  To make things a little more complex the prolog code uses Quintus
  libraries that depend on foreign code.

  Sample transcripts:

  C:
        bash-2.03$ make check
        gcc -Wall -Werror -DDEBUG "-I/q/tmp/sun4-5_3.4/generic/qplib3.4/embed"  myapp.c -c -o myapp.o
        gcc -Wall -Werror -DDEBUG "-I/q/tmp/sun4-5_3.4/generic/qplib3.4/embed" -fPIC myforeign.c -c -o myforeign.o
        qpc -c -v -o my_pl_code.qof testmodule.pl
        Quintus Prolog Release 3.4 (Sun 4, SunOS 5.7)
        Originally developed by Quintus Corporation, USA.
        Copyright (C) 1998, Swedish Institute of Computer Science.  All rights reserved.
        PO Box 1263, SE-164 29  Kista, Sweden. +46 8 633 1500
        Email: qpsupport@sics.se    WWW: http://www.sics.se/
        Licensed to SICS
        % compiling /hosts/krumelur/e1/sicstus/perm/sicstus/quintus/qprm1909/testmodule.pl...
        %  dependency on foreign file testforeign.o recorded
        % testmodule.pl compiled into my_pl_code.qof in module testmodule, 0.110 seconds
        qld -c -d -v -o my_pl_code.qof.o my_pl_code.qof

        Quintus Link Editor, Release 3.4
        Copyright (C) 1998, Swedish Institute of Computer Science.  All rights reserved.

        /q/tmp/sun4-5_3.4/bin3.4/sun4-5/qprte.qof:
        /hosts/krumelur/e1/sicstus/perm/sicstus/quintus/qprm1909/my_pl_code.qof:
         /q/tmp/sun4-5_3.4/generic/qplib3.4/library/lists.qof:
          /q/tmp/sun4-5_3.4/generic/qplib3.4/library/types.qof:
         /q/tmp/sun4-5_3.4/generic/qplib3.4/library/math.qof:
        /q/tmp/sun4-5_3.4/bin3.4/sun4-5/qcon /tmp/qp_FaWCz.qof -o my_pl_code.qof.o
        qcon: Undefined: user:runtime_entry/1
        File deleted: /tmp/qp_FaWCz.qof
        gcc myapp.o myforeign.o my_pl_code.qof.o -o myapp /q/tmp/sun4-5_3.4/bin3.4/sun4-5/qprte.o /q/tmp/sun4-5_3.4/bin3.4/sun4-5/libqp.a /q/tmp/sun4-5_3.4/generic/qplib3.4/library/sun4-5/libplm.a -lm -ldl
        ./myapp || { echo "Execution of myapp exited with error $?"; exit 1; }
        C: myapp.c:396
        C: myapp.c:320
        C: myapp.c:327
        C: myapp.c:339
        C: Looking up testmodule:do_something/2.....success
        C: Looking up testmodule:do_something_illegal/2.....success
        C: Looking up testmodule:do_something_nondet/1.....success
        C: Looking up testmodule:do_something_callback/2.....success
        C: Looking up testmodule:writeq/2.....success
        C: Looking up testmodule:flush_output/1.....success
        C: Looking up testmodule:nl/1.....success
        C: myapp.c:366
        C: do_something:
        Prolog: do_something(PARIS, _5209)
        C: do_something('PARIS', X) -> X='SIRAP'
        C: do_something_nondet(2):
        Prolog: do_something_nondet clause 1
        C: Solution 1: 6.48074
        Prolog: do_something_nondet clause 2
        C: Solution 2: 2.2
        C: do_something_nondet(42):
        Prolog: do_something_nondet clause 1
        C: Solution 1: 6.48074
        Prolog: do_something_nondet clause 2
        C: Solution 2: 2.2
        Prolog: do_something_nondet clause 3
        C: Solution 3: 3.3
        C: No more solutions (after 3 solutions)
        C: do_something_illegal(42):
        C: myapp.c:255
        Prolog: do_something_illegal(42, _5253)
        C: myapp.c:257
        C: First solution: 23
        C: myapp.c:279
        C: do_something_illegal(0) (should give divide by zero exception):
        C: myapp.c:255
        Prolog: do_something_illegal(0, _5253)
        C: myapp.c:257
        C: An exception occurred in do_something_illegal_pred, exception term: domain_error(_5263 is integer(1000/0),2,'non-zero number',1000/0,0)
        C: myapp.c:279
        C: do_something_callback(42)
        In Prolog do_something_callback(42, _5253).
        Prolog: calling callback_pred(43, _5263).
        C: In callback_fun(43)
        C: In real_callback_fun(43)
        C: In callback_fun(43), returning 44
        Prolog: called callback_pred(43, 44).
        C: do_something_callback(42)==45
        C: Done.
        bash-2.03$ 

C++
        bash-2.03$ make clean check C_DIALECT=cpp
        rm -f *.o *.qof myapp
        rm -f myforeign.cpp myapp.cpp
        echo "// This file was generated from myapp.c, it will be deleted by make clean!!" > myapp.cpp
        cat myapp.c >> myapp.cpp
        chmod a-w myapp.cpp
        gcc -Wall -Werror -DDEBUG "-I/q/tmp/sun4-5_3.4/generic/qplib3.4/embed"  myapp.cpp -c -o myapp.o
        echo "// This file was generated from myforeign.c, it will be deleted by make clean!!" > myforeign.cpp
        cat myforeign.c >> myforeign.cpp
        chmod a-w myforeign.cpp
        gcc -Wall -Werror -DDEBUG "-I/q/tmp/sun4-5_3.4/generic/qplib3.4/embed" -fPIC myforeign.cpp -c -o myforeign.o
        qpc -c -v -o my_pl_code.qof testmodule.pl
        Quintus Prolog Release 3.4 (Sun 4, SunOS 5.7)
        Originally developed by Quintus Corporation, USA.
        Copyright (C) 1998, Swedish Institute of Computer Science.  All rights reserved.
        PO Box 1263, SE-164 29  Kista, Sweden. +46 8 633 1500
        Email: qpsupport@sics.se    WWW: http://www.sics.se/
        Licensed to SICS
        % compiling /hosts/krumelur/e1/sicstus/perm/sicstus/quintus/qprm1909/testmodule.pl...
        %  dependency on foreign file testforeign.o recorded
        % testmodule.pl compiled into my_pl_code.qof in module testmodule, 0.080 seconds
        qld -c -d -v -o my_pl_code.qof.o my_pl_code.qof

        Quintus Link Editor, Release 3.4
        Copyright (C) 1998, Swedish Institute of Computer Science.  All rights reserved.

        /q/tmp/sun4-5_3.4/bin3.4/sun4-5/qprte.qof:
        /hosts/krumelur/e1/sicstus/perm/sicstus/quintus/qprm1909/my_pl_code.qof:
         /q/tmp/sun4-5_3.4/generic/qplib3.4/library/lists.qof:
          /q/tmp/sun4-5_3.4/generic/qplib3.4/library/types.qof:
         /q/tmp/sun4-5_3.4/generic/qplib3.4/library/math.qof:
        /q/tmp/sun4-5_3.4/bin3.4/sun4-5/qcon /tmp/qpVGaOKz.qof -o my_pl_code.qof.o
        qcon: Undefined: user:runtime_entry/1
        File deleted: /tmp/qpVGaOKz.qof
        gcc myapp.o myforeign.o my_pl_code.qof.o -o myapp /q/tmp/sun4-5_3.4/bin3.4/sun4-5/qprte.o /q/tmp/sun4-5_3.4/bin3.4/sun4-5/libqp.a /q/tmp/sun4-5_3.4/generic/qplib3.4/library/sun4-5/libplm.a -lm -ldl
        ./myapp || { echo "Execution of myapp exited with error $?"; exit 1; }
        C++: Static initializer in foreign code called, must be C++
        C++: Static initializer called, must be C++
        C++: myapp.cpp:397
        C++: myapp.cpp:321
        C++: myapp.cpp:328
        C++: myapp.cpp:340
        C++: Looking up testmodule:do_something/2.....success
        C++: Looking up testmodule:do_something_illegal/2.....success
        C++: Looking up testmodule:do_something_nondet/1.....success
        C++: Looking up testmodule:do_something_callback/2.....success
        C++: Looking up testmodule:writeq/2.....success
        C++: Looking up testmodule:flush_output/1.....success
        C++: Looking up testmodule:nl/1.....success
        C++: myapp.cpp:367
        C++: do_something:
        Prolog: do_something(PARIS, _5209)
        C++: do_something('PARIS', X) -> X='SIRAP'
        C++: do_something_nondet(2):
        Prolog: do_something_nondet clause 1
        C++: Solution 1: 6.48074
        Prolog: do_something_nondet clause 2
        C++: Solution 2: 2.2
        C++: do_something_nondet(42):
        Prolog: do_something_nondet clause 1
        C++: Solution 1: 6.48074
        Prolog: do_something_nondet clause 2
        C++: Solution 2: 2.2
        Prolog: do_something_nondet clause 3
        C++: Solution 3: 3.3
        C++: No more solutions (after 3 solutions)
        C++: do_something_illegal(42):
        C++: myapp.cpp:256
        Prolog: do_something_illegal(42, _5253)
        C++: myapp.cpp:258
        C++: First solution: 23
        C++: myapp.cpp:280
        C++: do_something_illegal(0) (should give divide by zero exception):
        C++: myapp.cpp:256
        Prolog: do_something_illegal(0, _5253)
        C++: myapp.cpp:258
        C++: An exception occurred in do_something_illegal_pred, exception term: domain_error(_5263 is integer(1000/0),2,'non-zero number',1000/0,0)
        C++: myapp.cpp:280
        C++: do_something_callback(42)
        In Prolog do_something_callback(42, _5253).
        Prolog: calling callback_pred(43, _5263).
        C++: In callback_fun(43)
        C++: In real_callback_fun(43)
        C++: In callback_fun(43), returning 44
        Prolog: called callback_pred(43, 44).
        C++: do_something_callback(42)==45
        C++: Done.
        bash-2.03$ 


 */

#include <unistd.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>

#include <quintus.h>

#ifdef DEBUG
#define Debug() do{ fprintf(stderr,LANG_TAG "%s:%d\n", __FILE__, (int)__LINE__);}while(0)
#else
#define Debug() do{}while(0)
#endif

/* Must match declaration in testforeign.c (belongs in a header) */
extern long real_callback_fun(long);

typedef struct open_query *Query;

static int prolog_init(int argc, char **argv);

struct open_query {
  struct open_query *next;      /* linked as a stack from open_queries */
  QP_qid qid0;
  QP_qid qid1;
  QP_term_ref vars;
};


#ifdef __cplusplus              /* C++ */
#define LANG_TAG "C++: "
#else  /* !C++ */
#define LANG_TAG "C: "
#endif /* !C++ */


/* Free list of term refs. QP is missing a method to free term refs. */
typedef struct term_ref_link {
  QP_term_ref ref;
  struct term_ref_link *next;
} term_ref_link;


static int inited = 0;

/* application specific predicates */
static QP_pred_ref do_something_pred;
static QP_pred_ref do_something_illegal_pred;
static QP_pred_ref do_something_nondet_pred;
static QP_pred_ref do_something_callback_pred;

/* builtin predicates */
static QP_pred_ref writeq_pred;
static QP_pred_ref flush_output_pred;
static QP_pred_ref nl_pred;

typedef struct {
  QP_pred_ref *pred;
  char *module;
  char *name;
  int arity;
} pred_def;

#define MAINMODULE "testmodule"

static pred_def pred_defs[] =
{
  /* Application specific predicates */
  {&do_something_pred, MAINMODULE, "do_something", 2},
  {&do_something_illegal_pred, MAINMODULE, "do_something_illegal", 2},
  {&do_something_nondet_pred, MAINMODULE, "do_something_nondet", 1},
  {&do_something_callback_pred, MAINMODULE, "do_something_callback", 2},


  /* Builtins. Note that these too need a :- extern/3 declaration and
     that the module where the extern declaration is done myst be
     passed when looking up the predicated even though they belong in
     the prolog module. */
  {&writeq_pred, MAINMODULE, "writeq", 2}, /* writeq(+string, +term), the string will be "user_error" */
  {&flush_output_pred, MAINMODULE, "flush_output", 1}, /* flush_output(+string), the string will be "user_error" */
  {&nl_pred, MAINMODULE, "nl", 1}, /* nl(+string), the string will be "user_error" */


  {0,0,0,0}
};

/* -------------------------------------------------------------------- */

static void print_exception(char const *culprit)
{
  int rc;
  QP_term_ref term  = QP_new_term_ref();

  rc = QP_exception_term(term);
  if (rc != QP_SUCCESS)
    {
      fprintf(stderr, LANG_TAG "An exception occurred in %s, no exception term\n", culprit);fflush(stderr);
      return;
    }

  fprintf(stderr, LANG_TAG "An exception occurred in %s, exception term: ", culprit);fflush(stderr);
  rc = QP_query(writeq_pred, "user_error", term);
  if (rc != QP_SUCCESS)
    {
      fprintf(stderr, LANG_TAG "ERROR, could not write exception %s\n", (rc == QP_FAILURE ? "QP_FAILURE" : (rc == QP_ERROR ? "QP_ERROR" : "UNKNOWN ERROR CODE")));fflush(stderr);
    }
  rc = QP_query(nl_pred, "user_error", term);
  if (rc != QP_SUCCESS)
    {
      fprintf(stderr, LANG_TAG "ERROR, could not nl(user_error) %s\n", (rc == QP_FAILURE ? "QP_FAILURE" : (rc == QP_ERROR ? "QP_ERROR" : "UNKNOWN ERROR CODE")));fflush(stderr);
    }
  rc = QP_query(flush_output_pred, "user_error", term);
  if (rc != QP_SUCCESS)
    {
      fprintf(stderr, LANG_TAG "ERROR, could not flush_output(user_error) %s\n", (rc == QP_FAILURE ? "QP_FAILURE" : (rc == QP_ERROR ? "QP_ERROR" : "UNKNOWN ERROR CODE")));fflush(stderr);
    }
  return;
}

/* -------------------------------------------------------------------- */

/* Simple example of calling a predicate for a single solution.
 */
static char *do_something(char *indata)
{
  int rc;
  char *result;
  
  result = NULL; /* not needed */

  rc = QP_query(do_something_pred, indata, &result);

  switch(rc)
    {
    case QP_SUCCESS:
      return result;
    case QP_FAILURE:
      fprintf(stderr, LANG_TAG "do_something_callback_pred failed\n");
      break;
    case QP_ERROR:
    default: /* shut up compiler */
      print_exception("do_something_pred");
    }
  return NULL;
}

static void do_something_nondet(int max)
{
  QP_qid q;
  int rc;
  int i;
  double result;
  
  result = 42; /* not needed */

  q = QP_open_query(do_something_nondet_pred, &result);
  if (q == QP_BAD_QID)
    {
      fprintf(stderr, LANG_TAG "!!BAD QID from: QP_open_query(do_something_nondet, indata, &result)\n"); fflush(stderr);
      return;
    }

  for (i = 0, rc = QP_SUCCESS; i < max && rc == QP_SUCCESS; i++)
    {
      rc = QP_next_solution(q);
      
      switch(rc)
        {
        case QP_SUCCESS:
          {
            fprintf(stderr, LANG_TAG "Solution %d: %g\n", i+1, result); fflush(stderr);
            break;
          }
        case QP_FAILURE:
          {
            fprintf(stderr, LANG_TAG "No more solutions (after %d solutions)\n", i); fflush(stderr);
            break;
          }
        case QP_ERROR:
        default: /* shut up compiler */
          {
            print_exception("do_something_nondet_pred");
            break;
          }
        }
    }
  (void) QP_close_query(q);
}



static void do_something_illegal(long indata)
{
  QP_qid q;
  int rc;
  long result;
  
  result = 42; /* not needed */

  q = QP_open_query(do_something_illegal_pred, indata, &result);
  if (q == QP_BAD_QID)
    {
      fprintf(stderr, LANG_TAG "!!BAD QID from: QP_open_query(do_something_illegal, indata, &result)\n"); fflush(stderr);
      return;
    }
  Debug();
  rc = QP_next_solution(q);
  Debug();
  
  switch(rc)
    {
    case QP_SUCCESS:
      {
        fprintf(stderr, LANG_TAG "First solution: %ld\n", result); fflush(stderr);
        break;
      }
    case QP_FAILURE:
      {
        fprintf(stderr, LANG_TAG "FAILED\n"); fflush(stderr);
        break;
      }
    case QP_ERROR:
    default: /* shut up compiler */
      {
        print_exception("do_something_illegal_pred");
        break;
      }
    }

  Debug();
  /* always do this unless open_query failed */
  (void) QP_close_query(q);
}

static void do_something_callback(long x)
{
  int rc;
  long result = 4711;

  rc = QP_query(do_something_callback_pred, x, &result);

  switch(rc)
    {
    case QP_SUCCESS:
      fprintf(stderr, LANG_TAG "do_something_callback(%ld)==%ld\n", x, result);  fflush(stderr);
      break;
    case QP_FAILURE:
      fprintf(stderr, LANG_TAG "do_something_callback_pred failed\n");
      break;
    case QP_ERROR:
    default: /* shut up compiler */
      print_exception("do_something_callback_pred");
      break;
    }
}



/*
Initialize QP runtime
Set up the predicates we will call from C
  QP_SUCCESS on success, QP_ERROR on error

  Safe to call multiple times. Arguments are ignored after the first
  successful call.
*/
static int prolog_init(int argc, char **argv)
{
  int rc;

  Debug();

  if (inited)
    {
      return QP_SUCCESS;
    }

  Debug();

  /* 
     Initialize QP runtime.
     You may wish to hide the real command line args, in that case
     pass something else, or 0,NULL.
  */
  rc = QP_initialize(argc, argv);
  if (rc != QP_SUCCESS)
    {
      return QP_ERROR;
    }
  Debug();

  /* Setup the predicates */
  {
    pred_def *def = &pred_defs[0];
    while ( def->pred )
      {
        #if DEBUG
        fprintf(stderr, LANG_TAG "Looking up %s:%s/%d...", def->module, def->name, def->arity);fflush(stderr);
        #endif/* DEBUG */
        *def->pred = QP_predicate(def->name, def->arity, def->module);
        if ( *def->pred == QP_BAD_PREDREF )
          {
            #if DEBUG
            fprintf(stderr, "..ERROR\n");fflush(stderr);
            #endif/* DEBUG */
            Debug();
            return QP_ERROR;
          }
        #if DEBUG
        fprintf(stderr, "..success\n");fflush(stderr);
        #endif/* DEBUG */

        def++;
      }
  }

  Debug();

  inited = 1;
  return QP_SUCCESS;
}

#ifdef __cplusplus
static int static_initializer(void)
{
  /* If this is called then static initializer works, implying the C++ is properly set up. */
  fprintf(stderr, LANG_TAG "Static initializer called, must be C++\n");fflush(stderr);
  return 42;
}

int statically_initialized = static_initializer(); /* only valid in C++ */
#endif /* __cplusplus */


long real_callback_fun(long x)
{
  fprintf(stderr, LANG_TAG "In real_callback_fun(%ld)\n", x);fflush(stderr);
  return x+1;
}

int main(int argc, char **argv)
{
  char *p;
  char *s = "PARIS";
  int rc;                       /* QP_SUCCESS, QP_ERROR */

  Debug();
  /* Init QP runtime. You can do this on-demand instead. */
  rc = prolog_init(argc, argv);

  if (rc != QP_SUCCESS)
    {
      Debug();
      exit(1);                  /* not the right thing in general. */
    }
  
  /* Other App specific stuff goes here */

  fprintf(stderr, LANG_TAG "do_something:\n"); fflush(stderr);
  p = do_something(s);
  if (p)
    {
      fprintf(stderr, LANG_TAG "do_something('%s', X) -> X='%s'\n", s, p); fflush(stderr); 
    }
  else
    {
      fprintf(stderr, LANG_TAG "do_something('%s', X) FAILED\n", s); fflush(stderr);
    }

  fprintf(stderr, LANG_TAG "do_something_nondet(2):\n"); fflush(stderr);
  do_something_nondet(2);       /* stop after 2 solutions */
  fprintf(stderr, LANG_TAG "do_something_nondet(42):\n");  fflush(stderr);
  do_something_nondet(42);      /* Will get all 3 and then fail */

  fprintf(stderr, LANG_TAG "do_something_illegal(42):\n");  fflush(stderr);
  do_something_illegal(42);

  fprintf(stderr, LANG_TAG "do_something_illegal(0) (should give divide by zero exception):\n");  fflush(stderr);
  do_something_illegal(0);      /* divide by zero */

  {
    long arg = 42;
    fprintf(stderr, LANG_TAG "do_something_callback(%ld)\n", arg);  fflush(stderr);
    do_something_callback(arg);
  }

  fprintf(stderr, LANG_TAG "Done.\n");  fflush(stderr);

  return 0;
}