home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / logo / powerlogo / utilities / words-lists < prev    next >
Text File  |  1992-11-10  |  11KB  |  342 lines
  1.  
  2. ;  Words-Lists
  3.  
  4. ;  Some procedures for processing words and lists. Some of these procedures
  5. ;  require sub-procedures defined in the default 'LOGO-Startup' file.
  6.  
  7. ; *** Print out contents of directory.
  8. make "dr [
  9.    procedure [ [ ] [ :d :p ] ]
  10.    vpr ( sdir :d :p ) ]
  11.  
  12. ; *** Print out contents of directory, and all sub directories.
  13. make "dra [
  14.    procedure [ [ ] [ :d :p ] ]
  15.    vpr ( sdira :d :p ) ]
  16.  
  17. ; *** Output list of all procedures needed to run the named procedure.
  18. make "link [
  19.    procedure [ [ :proc-name ] [ ] [ :link-list ] ]
  20.    if procedurep :proc-name
  21.    [  make "link-list se :proc-name [ ]
  22.       linksub bf bf thing :proc-name ]
  23.    [  ( pr :proc-name [ is not a procedure ] ) output [ ] ]
  24.    output :link-list ]
  25.  
  26. make "linksub [
  27.    procedure [ [ :proc-list ] [ ] [ :lfirst ] ]
  28.    if emptyp :proc-list [ stop ] [ ]
  29.    make "lfirst first :proc-list
  30.    cond
  31.    [  [  listp :lfirst ]   [ linksub :lfirst ]
  32.       [  procedurep :lfirst ]
  33.       [  if memberp :lfirst :link-list
  34.          [ ]
  35.          [  make "link-list fput :lfirst :link-list
  36.             linksub bf bf thing :lfirst ] ] ]
  37.    linksub bf :proc-list stop ]
  38.  
  39. ; *** convert all upper case letters to lower case.
  40. make "lcase [
  41.    procedure [ [ :w ] [ ] [ :l :c :o ] ]
  42.    if listp :w
  43.    [  make "o [ ]
  44.       while [ not emptyp :w ]
  45.       [  make "o fput lcase first :w :o
  46.          make "w bf :w ]
  47.       output reverse :o ]
  48.    [  make "o " 
  49.       make "c count :w
  50.       repeat :c
  51.       [  make "l item :c :w
  52.          make "o fput   if    >>= 65 90 ascii :l
  53.                               [ char + ascii :l 32 ]
  54.                               [ :l ]
  55.                         :o
  56.          dec "c ]
  57.       output :o ] ]
  58.  
  59. ; *** convert all lower case letters to upper case.
  60. make "ucase [
  61.    procedure [ [ :w ] [ ] [ :l :c :o ] ]
  62.    if listp :w
  63.    [  make "o [ ]
  64.       while [ not emptyp :w ]
  65.       [  make "o fput ucase first :w :o
  66.          make "w bf :w ]
  67.       output reverse :o ]
  68.    [  make "o " 
  69.       make "c count :w
  70.       repeat :c
  71.       [  make "l item :c :w
  72.          make "o fput   if    >>= 97 122 ascii :l
  73.                               [ char - ascii :l 32 ]
  74.                               [ :l ]
  75.                         :o
  76.          dec "c ]
  77.       output :o ] ]
  78.  
  79. ; *** Output list of all words in the list that fit the pattern.
  80. make "patfilter [
  81.    procedure [ [ :p :f ] [ ] [ :o ] ]
  82.    make "p lcase :p
  83.    while [ not emptyp :f ]
  84.    [  if matchp :p lcase first :f
  85.       [  make "o fput first :f :o ]
  86.       [ ]
  87.       make "f bf :f ]
  88.    output reverse :o ]
  89.  
  90. ; *** Output sorted directory list.
  91. make "sdir [
  92.    procedure [ [ ] [ :d :p ] [ :c :t :dn :fn ] ]
  93.    if emptyp :d [ make "c dir ] [ make "c ( dir :d ) ]
  94.    if emptyp :p [ ] [ make "c patfilter :p :c ]
  95.    while [ not emptyp :c ] [
  96.       make "t first :c
  97.       make "c bf :c
  98.       if = "/ last :t
  99.          [ make "dn fput :t :dn ] 
  100.          [ make "fn fput :t :fn ] ]
  101.    output
  102.       se if > count :dn 1 [ sort "alphap :dn ] [ :dn ]
  103.          if > count :fn 1 [ sort "alphap :fn ] [ :fn ] ]
  104.  
  105. ; *** Output sorted directory list.
  106. make "sdira [
  107.    procedure [ [ ] [ :d :p ] [ :c :t :dn :fn :w ] ]
  108.    if emptyp :d
  109.       [  make "c dir
  110.          make "d "  ]
  111.       [  make "c ( dir :d )
  112.          if or = "/ last :d = ": last :d
  113.             [  ]
  114.             [  make "d word :d "/ ] ]
  115.    if emptyp :p [ ] [ make "c patfilter :p :c ]
  116.    while [ not emptyp :c ] [
  117.       make "t first :c
  118.       make "c bf :c
  119.       if = "/ last :t
  120.          [ make "dn fput :t :dn ] 
  121.          [ make "fn fput :t :fn ] ]
  122.    make "dn if > count :dn 1 [ sort [ not alphap ] :dn ] [ :dn ]
  123.    while [ not emptyp :dn ] [
  124.       make "t first :dn
  125.       make "dn bf :dn
  126.       make "c fput ( sdira word :d :t :p ) :c
  127. ;      make "c fput ( sdira word :d :t ) :c
  128.       make "c fput :t :c ] 
  129.    output se :c if > count :fn 1 [ sort "alphap :fn ] [ :fn ] ]
  130.  
  131.  
  132. ; MATCHP ***************************************************************
  133. ;    Output true if word fits pattern.
  134. ;  matchp pattern word
  135.  
  136. make "matchp [
  137.   procedure [ [ :_mc_pat :_mc_obj ] [ ] [ :_mc_i :_mc_j ] ]
  138.   cond [
  139.     [ listp :_mc_pat ]
  140.       [ while [ not emptyp :_mc_pat ] [
  141.           if matchp first :_mc_pat :_mc_obj
  142.              [ op true ]
  143.              [ make "_mc_pat bf :_mc_pat ] ]
  144.         op false ]
  145.     [ memberp "~ :_mc_pat ]
  146.       [ op not matchp bf :_mc_pat :_mc_obj ]
  147.     [ memberp "* :_mc_pat ]
  148.       [ if = "* first :_mc_pat
  149.            [ dowhile [
  150.                make "_mc_pat bf :_mc_pat
  151.                if emptyp :_mc_pat  [ op true ]  [ ]
  152.              ] [ = "* first :_mc_pat ]
  153.              if memberp "* :_mc_pat
  154.                 [ if emptyp :_mc_obj
  155.                      [ op false ]
  156.                      [ if memberp :_mc_pat :_mc_obj
  157.                           [ make "_mc_i first :_mc_pat
  158.                             while [ not = :_mc_i first :_mc_obj ] [
  159.                               make "_mc_obj bf :_mc_obj
  160.                               if emptyp :_mc_obj  [ op false ]  [ ]  ]
  161.                             op if matchp bf :_mc_pat bf :_mc_obj
  162.                               [ true ]
  163.                               [ matchp fput "* :_mc_pat bf :_mc_obj ] ]
  164.                           [ op false ] ] ]
  165.                 [ make "_mc_i count :_mc_pat
  166.                   make "_mc_j count :_mc_obj
  167.                   op if <= :_mc_i :_mc_j
  168.                     [ = :_mc_pat
  169.                         items ( - :_mc_j :_mc_i -1 ) :_mc_i :_mc_obj ]
  170.                     [ false ] ] ]
  171.            [ make "_mc_i 2
  172.              while [ not = "* item :_mc_i :_mc_pat ] [
  173.                make "_mc_i + :_mc_i 1 ]
  174.              make "_mc_i - :_mc_i 1
  175.              op if <= :_mc_i count :_mc_obj
  176.                [ if = items 1 :_mc_i :_mc_pat
  177.                       items 1 :_mc_i :_mc_obj
  178.                     [ matchp restof :_mc_i :_mc_pat
  179.                              restof :_mc_i :_mc_obj ]
  180.                     [ false ] ]
  181.                [ false ] ] ]
  182.     [ true ]
  183.       [ op = :_mc_pat :_mc_obj ] ] ]
  184.  
  185.  
  186. ; EVAL *****************************************************************
  187. ;    Similar to `run', but can be used on a word or a list.
  188. ;  eval expr
  189.  
  190. make "eval [
  191.   procedure [ [ :_ev_expr ] ]
  192.   op run if listp :_ev_expr [ :_ev_expr ] [ fput :_ev_expr [ ] ] ]
  193.  
  194.  
  195. ; FOR ******************************************************************
  196. ;    `For' loop structure.
  197. ;    Loop variable should be local to calling procedure.
  198. ;  for loop-var init-val final-val step run-list
  199.  
  200. make "for [
  201.   procedure [ [ :_fr_var :_fr_init :_fr_final :_fr_step :_fr_instr ] ]
  202.   make :_fr_var :_fr_init
  203.   while [ if >0 :_fr_step [ <= thing :_fr_var :_fr_final ]
  204.                           [ >= thing :_fr_var :_fr_final ] ] [
  205.     run :_fr_instr
  206.     make :_fr_var + thing :_fr_var :_fr_step ] ]
  207.  
  208.  
  209. ; FOREACH ****************************************************************
  210. ;    `For' loop structure that processes through a list.
  211. ;    Loop variable should be local to calling procedure.
  212. ;  foreach loop-var value-list run-list
  213.  
  214. make "foreach [
  215.   procedure [ [ :_fe_var :_fe_list :_fe_instr ] ]
  216.   while [ not emptyp :_fe_list ] [
  217.     make :_fe_var first :_fe_list
  218.     run :_fe_instr
  219.     make "_fe_list bf :_fe_list ] ]
  220.  
  221.  
  222. ; REDUCE ***************************************************************
  223. ;    Structural recursion procedure.
  224. ;  reduce func zero-case input-obj
  225.  
  226. make "reduce [
  227.   procedure [ [ :_rd_func :_rd_zero :_rd_obj ] ]
  228.   op if emptyp :_rd_obj
  229.     [ :_rd_zero ]
  230.     [ run se :_rd_func
  231.       [ first :_rd_obj reduce :_rd_func :_rd_zero bf :_rd_obj ] ] ]
  232.  
  233.  
  234. ; WORD->LIST ***********************************************************
  235. ;    Expands the characters of a word into a list.
  236. ;  word->list word
  237.  
  238. make "word->list [
  239.   procedure [ [ :_wl_wrd ] ]
  240.   op reduce "se [ ] :_wl_wrd ]
  241.  
  242.  
  243. ; LIST->WORD ***********************************************************
  244. ;    Combines the contents of a list into a word.
  245. ;  list->word list
  246.  
  247. make "list->word [
  248.   procedure [ [ :_lw_lst ] ]
  249.   op reduce "word " :_lw_lst ]
  250.  
  251.  
  252. ; WORD->ASCII **********************************************************
  253. ;    Expands a word into a list of ascii values.
  254. ;  word->ascii word
  255.  
  256. make "word->ascii [
  257.   procedure [ [ :_wa_wrd ] ]
  258.   op reduce [ se ascii ] [ ] :_wa_wrd ]
  259.  
  260.  
  261. ; MAP ******************************************************************
  262. ;    Apply a function over the items of a list or word.
  263. ;  map func object
  264.  
  265. make "map [
  266. procedure [ [ :_mp_func :_mp_obj ] ]
  267.   op if emptyp :_mp_obj
  268.     [ :_mp_obj ]
  269.     [ fput run se :_mp_func [ first :_mp_obj ]
  270.        map :_mp_func bf :_mp_obj ] ]
  271.  
  272.  
  273. ; MAP2 *****************************************************************
  274. ;    Output an object that results from applying a function on two
  275. ;     objects.
  276. ;  map2 function object1 object2
  277.  
  278. make "map2 [
  279.   procedure [ [ :_m2_func :_m2_obj1 :_m2_obj2 ] ]
  280.   op if emptyp :_m2_obj1
  281.     [ :_m2_obj2 ]
  282.     [ if emptyp :_m2_obj2
  283.          [ :_m2_obj1 ]
  284.          [ fput run se :_m2_func [ first :_m2_obj1 first :_m2_obj2 ]
  285.             map2 :_m2_func bf :_m2_obj1 bf :_m2_obj2 ] ] ]
  286.  
  287.  
  288. ; COL-PRINT ******************************************************************
  289. ;    Print out the contents of a list in columns.
  290. ;  col-print list ( margin spacing )
  291.  
  292. make "col-print [
  293.   procedure [ [ :_cp_lst ] [ :_cp_marg :_cp_spac ]
  294.               [ :_cp_width :_cp_cnt :_cp_rows :_cp_r :_cp_c :_cp_i ] ]
  295.   if wordp  :_cp_lst   [ make "_cp_lst fput :_cp_lst [ ] ]  [ ]
  296.   if emptyp :_cp_marg  [ make "_cp_marg   0 ]  [ ]
  297.   if emptyp :_cp_spac  [ make "_cp_spac   4 ]  [ ]
  298.   make "_cp_width first window-size
  299.   make "_cp_cnt count :_cp_lst
  300.   make "_cp_cols int / + ( - :_cp_width 1 :_cp_marg ) :_cp_spac
  301.                        + max map "count :_cp_lst :_cp_spac
  302.   if =0 :_cp_cols  [ make "_cp_cols 1 ]  [ ]
  303.   make "_cp_rows + 1 int / - :_cp_cnt 1 :_cp_cols
  304.   make "_cp_spac int / - :_cp_width :_cp_marg :_cp_cols
  305.   for   "_cp_r  1  :_cp_rows      1 [
  306.     for "_cp_c  0  - :_cp_cols 1  1 [
  307.       make "_cp_i + :_cp_r * :_cp_rows :_cp_c
  308.       if <= :_cp_i :_cp_cnt
  309.          [ setcursor fput + :_cp_marg * :_cp_c :_cp_spac bf cursor
  310.            type item :_cp_i :_cp_lst ]
  311.          [ ] ]
  312.     pr [ ] ] ]
  313.  
  314.  
  315. ; WINDOW-SIZE **********************************************************
  316. ;    Output the limits for the cursor for the command window.
  317.  
  318. make "window-size [
  319.   procedure [ [ ] [ ] [ :_ws_pos :_ws_lim ] ]
  320.   make "_ws_pos cursor
  321.   setcursor [ 10000 10000 ]
  322.   make "_ws_lim cursor
  323.   setcursor :_ws_pos
  324.   op list + first :_ws_lim 1 + last :_ws_lim 1 ]
  325.  
  326.  
  327. ; MAX ******************************************************************
  328. ;    Maximum of a list of numbers.
  329. ;  max num-list
  330.  
  331. make "max [
  332.   procedure [ [ :_mx_lst ] [ ] [ :_mx_func ] ]
  333.   make "_mx_func [
  334.     procedure [ [ :_mx_x :_mx_y ] ]
  335.     op if >= :_mx_x :_mx_y [ :_mx_x ] [ :_mx_y ] ]
  336.   op reduce "_mx_func first :_mx_lst bf :_mx_lst ]
  337.  
  338.  
  339.  
  340.  
  341.  
  342.