;  Words-Lists

;  Some procedures for processing words and lists. Some of these procedures
;  require sub-procedures defined in the default 'LOGO-Startup' file.

; *** Print out contents of directory.
make "dr [
   procedure [ [ ] [ :d :p ] ]
   vpr ( sdir :d :p ) ]

; *** Print out contents of directory, and all sub directories.
make "dra [
   procedure [ [ ] [ :d :p ] ]
   vpr ( sdira :d :p ) ]

; *** Output list of all procedures needed to run the named procedure.
make "link [
   procedure [ [ :proc-name ] [ ] [ :link-list ] ]
   if procedurep :proc-name
   [  make "link-list se :proc-name [ ]
      linksub bf bf thing :proc-name ]
   [  ( pr :proc-name [ is not a procedure ] ) output [ ] ]
   output :link-list ]

make "linksub [
   procedure [ [ :proc-list ] [ ] [ :lfirst ] ]
   if emptyp :proc-list [ stop ] [ ]
   make "lfirst first :proc-list
   cond
   [  [  listp :lfirst ]   [ linksub :lfirst ]
      [  procedurep :lfirst ]
      [  if memberp :lfirst :link-list
         [ ]
         [  make "link-list fput :lfirst :link-list
            linksub bf bf thing :lfirst ] ] ]
   linksub bf :proc-list stop ]

; *** convert all upper case letters to lower case.
make "lcase [
   procedure [ [ :w ] [ ] [ :l :c :o ] ]
   if listp :w
   [  make "o [ ]
      while [ not emptyp :w ]
      [  make "o fput lcase first :w :o
         make "w bf :w ]
      output reverse :o ]
   [  make "o " 
      make "c count :w
      repeat :c
      [  make "l item :c :w
         make "o fput   if    >>= 65 90 ascii :l
                              [ char + ascii :l 32 ]
                              [ :l ]
                        :o
         dec "c ]
      output :o ] ]

; *** convert all lower case letters to upper case.
make "ucase [
   procedure [ [ :w ] [ ] [ :l :c :o ] ]
   if listp :w
   [  make "o [ ]
      while [ not emptyp :w ]
      [  make "o fput ucase first :w :o
         make "w bf :w ]
      output reverse :o ]
   [  make "o " 
      make "c count :w
      repeat :c
      [  make "l item :c :w
         make "o fput   if    >>= 97 122 ascii :l
                              [ char - ascii :l 32 ]
                              [ :l ]
                        :o
         dec "c ]
      output :o ] ]

; *** Output list of all words in the list that fit the pattern.
make "patfilter [
   procedure [ [ :p :f ] [ ] [ :o ] ]
   make "p lcase :p
   while [ not emptyp :f ]
   [  if matchp :p lcase first :f
      [  make "o fput first :f :o ]
      [ ]
      make "f bf :f ]
   output reverse :o ]

; *** Output sorted directory list.
make "sdir [
   procedure [ [ ] [ :d :p ] [ :c :t :dn :fn ] ]
   if emptyp :d [ make "c dir ] [ make "c ( dir :d ) ]
   if emptyp :p [ ] [ make "c patfilter :p :c ]
   while [ not emptyp :c ] [
      make "t first :c
      make "c bf :c
      if = "/ last :t
         [ make "dn fput :t :dn ] 
         [ make "fn fput :t :fn ] ]
   output
      se if > count :dn 1 [ sort "alphap :dn ] [ :dn ]
         if > count :fn 1 [ sort "alphap :fn ] [ :fn ] ]

; *** Output sorted directory list.
make "sdira [
   procedure [ [ ] [ :d :p ] [ :c :t :dn :fn :w ] ]
   if emptyp :d
      [  make "c dir
         make "d "  ]
      [  make "c ( dir :d )
         if or = "/ last :d = ": last :d
            [  ]
            [  make "d word :d "/ ] ]
   if emptyp :p [ ] [ make "c patfilter :p :c ]
   while [ not emptyp :c ] [
      make "t first :c
      make "c bf :c
      if = "/ last :t
         [ make "dn fput :t :dn ] 
         [ make "fn fput :t :fn ] ]
   make "dn if > count :dn 1 [ sort [ not alphap ] :dn ] [ :dn ]
   while [ not emptyp :dn ] [
      make "t first :dn
      make "dn bf :dn
      make "c fput ( sdira word :d :t :p ) :c
;      make "c fput ( sdira word :d :t ) :c
      make "c fput :t :c ] 
   output se :c if > count :fn 1 [ sort "alphap :fn ] [ :fn ] ]


; MATCHP ***************************************************************
;    Output true if word fits pattern.
;  matchp pattern word

make "matchp [
  procedure [ [ :_mc_pat :_mc_obj ] [ ] [ :_mc_i :_mc_j ] ]
  cond [
    [ listp :_mc_pat ]
      [ while [ not emptyp :_mc_pat ] [
          if matchp first :_mc_pat :_mc_obj
             [ op true ]
             [ make "_mc_pat bf :_mc_pat ] ]
        op false ]
    [ memberp "~ :_mc_pat ]
      [ op not matchp bf :_mc_pat :_mc_obj ]
    [ memberp "* :_mc_pat ]
      [ if = "* first :_mc_pat
           [ dowhile [
               make "_mc_pat bf :_mc_pat
               if emptyp :_mc_pat  [ op true ]  [ ]
             ] [ = "* first :_mc_pat ]
             if memberp "* :_mc_pat
                [ if emptyp :_mc_obj
                     [ op false ]
                     [ if memberp :_mc_pat :_mc_obj
                          [ make "_mc_i first :_mc_pat
                            while [ not = :_mc_i first :_mc_obj ] [
                              make "_mc_obj bf :_mc_obj
                              if emptyp :_mc_obj  [ op false ]  [ ]  ]
                            op if matchp bf :_mc_pat bf :_mc_obj
                              [ true ]
                              [ matchp fput "* :_mc_pat bf :_mc_obj ] ]
                          [ op false ] ] ]
                [ make "_mc_i count :_mc_pat
                  make "_mc_j count :_mc_obj
                  op if <= :_mc_i :_mc_j
                    [ = :_mc_pat
                        items ( - :_mc_j :_mc_i -1 ) :_mc_i :_mc_obj ]
                    [ false ] ] ]
           [ make "_mc_i 2
             while [ not = "* item :_mc_i :_mc_pat ] [
               make "_mc_i + :_mc_i 1 ]
             make "_mc_i - :_mc_i 1
             op if <= :_mc_i count :_mc_obj
               [ if = items 1 :_mc_i :_mc_pat
                      items 1 :_mc_i :_mc_obj
                    [ matchp restof :_mc_i :_mc_pat
                             restof :_mc_i :_mc_obj ]
                    [ false ] ]
               [ false ] ] ]
    [ true ]
      [ op = :_mc_pat :_mc_obj ] ] ]


; EVAL *****************************************************************
;    Similar to `run', but can be used on a word or a list.
;  eval expr

make "eval [
  procedure [ [ :_ev_expr ] ]
  op run if listp :_ev_expr [ :_ev_expr ] [ fput :_ev_expr [ ] ] ]


; FOR ******************************************************************
;    `For' loop structure.
;    Loop variable should be local to calling procedure.
;  for loop-var init-val final-val step run-list

make "for [
  procedure [ [ :_fr_var :_fr_init :_fr_final :_fr_step :_fr_instr ] ]
  make :_fr_var :_fr_init
  while [ if >0 :_fr_step [ <= thing :_fr_var :_fr_final ]
                          [ >= thing :_fr_var :_fr_final ] ] [
    run :_fr_instr
    make :_fr_var + thing :_fr_var :_fr_step ] ]


; FOREACH ****************************************************************
;    `For' loop structure that processes through a list.
;    Loop variable should be local to calling procedure.
;  foreach loop-var value-list run-list

make "foreach [
  procedure [ [ :_fe_var :_fe_list :_fe_instr ] ]
  while [ not emptyp :_fe_list ] [
    make :_fe_var first :_fe_list
    run :_fe_instr
    make "_fe_list bf :_fe_list ] ]


; REDUCE ***************************************************************
;    Structural recursion procedure.
;  reduce func zero-case input-obj

make "reduce [
  procedure [ [ :_rd_func :_rd_zero :_rd_obj ] ]
  op if emptyp :_rd_obj
    [ :_rd_zero ]
    [ run se :_rd_func
      [ first :_rd_obj reduce :_rd_func :_rd_zero bf :_rd_obj ] ] ]


; WORD->LIST ***********************************************************
;    Expands the characters of a word into a list.
;  word->list word

make "word->list [
  procedure [ [ :_wl_wrd ] ]
  op reduce "se [ ] :_wl_wrd ]


; LIST->WORD ***********************************************************
;    Combines the contents of a list into a word.
;  list->word list

make "list->word [
  procedure [ [ :_lw_lst ] ]
  op reduce "word " :_lw_lst ]


; WORD->ASCII **********************************************************
;    Expands a word into a list of ascii values.
;  word->ascii word

make "word->ascii [
  procedure [ [ :_wa_wrd ] ]
  op reduce [ se ascii ] [ ] :_wa_wrd ]


; MAP ******************************************************************
;    Apply a function over the items of a list or word.
;  map func object

make "map [
procedure [ [ :_mp_func :_mp_obj ] ]
  op if emptyp :_mp_obj
    [ :_mp_obj ]
    [ fput run se :_mp_func [ first :_mp_obj ]
       map :_mp_func bf :_mp_obj ] ]


; MAP2 *****************************************************************
;    Output an object that results from applying a function on two
;     objects.
;  map2 function object1 object2

make "map2 [
  procedure [ [ :_m2_func :_m2_obj1 :_m2_obj2 ] ]
  op if emptyp :_m2_obj1
    [ :_m2_obj2 ]
    [ if emptyp :_m2_obj2
         [ :_m2_obj1 ]
         [ fput run se :_m2_func [ first :_m2_obj1 first :_m2_obj2 ]
            map2 :_m2_func bf :_m2_obj1 bf :_m2_obj2 ] ] ]


; COL-PRINT ******************************************************************
;    Print out the contents of a list in columns.
;  col-print list ( margin spacing )

make "col-print [
  procedure [ [ :_cp_lst ] [ :_cp_marg :_cp_spac ]
              [ :_cp_width :_cp_cnt :_cp_rows :_cp_r :_cp_c :_cp_i ] ]
  if wordp  :_cp_lst   [ make "_cp_lst fput :_cp_lst [ ] ]  [ ]
  if emptyp :_cp_marg  [ make "_cp_marg   0 ]  [ ]
  if emptyp :_cp_spac  [ make "_cp_spac   4 ]  [ ]
  make "_cp_width first window-size
  make "_cp_cnt count :_cp_lst
  make "_cp_cols int / + ( - :_cp_width 1 :_cp_marg ) :_cp_spac
                       + max map "count :_cp_lst :_cp_spac
  if =0 :_cp_cols  [ make "_cp_cols 1 ]  [ ]
  make "_cp_rows + 1 int / - :_cp_cnt 1 :_cp_cols
  make "_cp_spac int / - :_cp_width :_cp_marg :_cp_cols
  for   "_cp_r  1  :_cp_rows      1 [
    for "_cp_c  0  - :_cp_cols 1  1 [
      make "_cp_i + :_cp_r * :_cp_rows :_cp_c
      if <= :_cp_i :_cp_cnt
         [ setcursor fput + :_cp_marg * :_cp_c :_cp_spac bf cursor
           type item :_cp_i :_cp_lst ]
         [ ] ]
    pr [ ] ] ]


; WINDOW-SIZE **********************************************************
;    Output the limits for the cursor for the command window.

make "window-size [
  procedure [ [ ] [ ] [ :_ws_pos :_ws_lim ] ]
  make "_ws_pos cursor
  setcursor [ 10000 10000 ]
  make "_ws_lim cursor
  setcursor :_ws_pos
  op list + first :_ws_lim 1 + last :_ws_lim 1 ]


; MAX ******************************************************************
;    Maximum of a list of numbers.
;  max num-list

make "max [
  procedure [ [ :_mx_lst ] [ ] [ :_mx_func ] ]
  make "_mx_func [
    procedure [ [ :_mx_x :_mx_y ] ]
    op if >= :_mx_x :_mx_y [ :_mx_x ] [ :_mx_y ] ]
  op reduce "_mx_func first :_mx_lst bf :_mx_lst ]