shrub/j/6/ut_fire.c

/* j/6/fire.c
**
** This file is in the public domain.
*/
#include "all.h"


/* logic
*/
  static u3_bean
  _fire_mull(u3_noun van,
             u3_noun sut,
             u3_noun dox,
             u3_noun gen)
  {
    u3_noun rib = u3_cr_at(u3_cqfu_van_rib, van);
    u3_noun key = u3nt(u3k(sut),
                               u3k(dox),
                               u3k(gen));
    u3_bean ret;

    if ( u3_yes == u3_cqdi_has(rib, key) ) {
      ret = u3_yes;
    }
    else {
      u3_noun rob = u3_cqdi_put(rib, key);
      u3_noun von = u3_ci_molt(u3k(van),
                                      u3_cqfu_van_rib, u3k(rob),
                                      0);
      ret = u3_cqfu_mull(von, sut, c3__noun, dox, gen);

      u3z(von);
      u3z(rob);
    }
    u3z(key);
    return ret;
  }

  static u3_noun
  _fire_each(u3_noun van,
             u3_noun vet,
             u3_noun typ,
             u3_noun gat)
  {
    u3_noun p_typ, q_typ, pq_typ, qq_typ, rq_typ;
    u3_noun h_gat, t_gat;

    if ( (u3_no == u3du(typ)) || (c3__core != u3h(typ)) ) {
      return u3_cm_error("fire-core");
    } else if
         ( (u3_no == u3_cr_cell(u3t(typ), &p_typ, &q_typ)) ||
           (u3_no == u3_cr_trel(q_typ, &pq_typ, &qq_typ, &rq_typ)) ||
           (u3_no == u3_cr_cell(gat, &h_gat, &t_gat)) )
    {
      return u3_cm_bail(c3__fail);
    } else {
      u3_noun dox = u3nt
        (c3__core, u3k(qq_typ), u3k(q_typ));

      if ( c3__ash == u3h(gat) ) {
        if ( (u3_yes == vet) &&
             (u3_no == u3_cqfu_nest
                (van, qq_typ, u3_yes, p_typ)) )
        {
#if 0
          u3_noun dun = u3_cqfu_dunq(van, "need", qq_typ);
          u3_noun niz = u3_cqfu_dunq(van, "have", p_typ);

          u3_ct_push(u3nc(c3__mean, niz));
          u3_ct_push(u3nc(c3__mean, dun));
#endif
          return u3_cm_error("fire-dry");
        }
        else {
          return u3nc(dox, u3k(t_gat));
        }
      }
      else {
        c3_assert(c3__elm == u3h(gat));

        if ( (u3_yes == vet) &&
             // (u3_no == u3_cr_sing(p_typ, qq_typ)) &&
             (u3_no == _fire_mull(van, typ, dox, t_gat)) )
        {
#if 0
          u3_noun dun = u3_cqfu_dunq(van, "wild", typ);
          u3_noun niz = u3_cqfu_dunq(van, "tame", dox);

          u3_ct_push(u3nc(c3__mean, dun));
          u3_ct_push(u3nc(c3__mean, niz));
#endif
          return u3_cm_error("fire-wet");
        }
        else {
          u3z(dox);
          return u3nc(u3k(typ), u3k(t_gat));
        }
      }
    }
  }

  static u3_noun
  _fire_in(
           u3_noun van,
           u3_noun vet,
           u3_noun hag)
  {
    if ( u3_nul == hag ) {
      return u3_nul;
    }
    else {
      u3_noun i_hag = u3h(hag);
      u3_noun t_hag = u3t(hag);

      if ( u3_no == u3du(i_hag) ) {
        return u3_cm_bail(c3__fail);
      } else {
        return u3nc
          (_fire_each(van, vet, u3h(i_hag), u3t(i_hag)),
                  _fire_in(van, vet, t_hag));
      }
    }
  }
  u3_noun
  _cqfu_fire(
                        u3_noun van,
                        u3_noun sut,
                        u3_noun hag)
  {
    u3_bean vet = u3_cr_at(u3_cqfu_van_vet, van);

    {
      if ( (u3_yes == u3du(hag)) && (u3_nul == u3t(hag)) ) {
        u3_noun i_hag = u3h(hag);
        u3_noun pi_hag = u3h(i_hag);
        u3_noun qi_hag = u3t(i_hag);

        if ( c3__elm == u3h(qi_hag) ) {
          u3_noun qqi_hag = u3t(qi_hag);

          if ( u3_yes == u3du(qqi_hag) &&
              (u3_nul == u3h(qqi_hag)) &&
              (1 == u3t(qqi_hag)) )
          {
            return u3k(pi_hag);
          }
        }
      }
    }
    return u3nc(c3__hold, _fire_in(van, vet, hag));
  }

/* boilerplate
*/
  u3_noun
  u3_cwfu_fire(
                       u3_noun cor)
  {
    u3_noun sut, hag, van;

    if ( (u3_no == u3_cr_mean(cor, u3_cv_sam, &hag, u3_cv_con, &van, 0)) ||
         (u3_none == (sut = u3_cr_at(u3_cv_sam, van))) )
    {
      return u3_cm_bail(c3__fail);
    } else {
      return _cqfu_fire(van, sut, hag);
    }
  }

  u3_noun
  u3_cqfu_fire(u3_noun van,
                        u3_noun sut,
                        u3_noun hag)
  {
    return _cqfu_fire(van, sut, hag);
  }