home *** CD-ROM | disk | FTP | other *** search
/ Fish 'n' More 2 / fishmore-publicdomainlibraryvol.ii1991xetec.iso / fish / languages / powerlogo / logo-startup < prev    next >
Text File  |  1990-10-10  |  12KB  |  413 lines
  1.  
  2. ;  This file contains some usefull procedures and constants.
  3.  
  4. ; *********************************************************************
  5. ;  Set amount of memory reserved by LOGO.
  6. ( system 2 122880 )
  7.  
  8. ;  Scramble random number generater.
  9. ( seedrand * 100 seconds )
  10.  
  11. ;  Has this file allready been loaded?
  12. if buriedp "startup-stuff [ unbury :startup-stuff ] [ ]
  13.  
  14. ; *********************************************************************
  15. ;  Numerical constants.
  16.  
  17. make "e  2.71828182845904523536
  18. make "pi 3.14159265358979323846
  19.  
  20. ; *********************************************************************
  21. ;  all
  22. ;     Output list of all names.
  23.  
  24. make "all [ procedure [ ] output se namelist burylist ] 
  25.  
  26. ; *********************************************************************
  27. ;  allnames
  28. ;     Output list of names bound to something other than procedures.
  29.  
  30. make "allnames [ 
  31.    procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
  32.    make "scr-n se burylist namelist 
  33.    dowhile 
  34.    [  make "scr-x first :scr-n 
  35.       make "scr-n bf :scr-n 
  36.       if (  or primitivep :scr-x 
  37.             procedurep :scr-x 
  38.             if > 4 count :scr-x 
  39.             [  false ] 
  40.             [  = "scr- items 1 4 :scr-x ] ) 
  41.       [ ] 
  42.       [  make "scr-o fput :scr-x :scr-o ] ] 
  43.    [ not emptyp :scr-n ] 
  44.    output :scr-o ] 
  45.  
  46. ; *********************************************************************
  47. ;  allprocs
  48. ;     Output list of names bound to procedures.
  49.  
  50. make "allprocs [ 
  51.    procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
  52.    make "scr-n se burylist namelist 
  53.    dowhile 
  54.    [  make "scr-x first :scr-n 
  55.       make "scr-n bf :scr-n 
  56.       if procedurep :scr-x 
  57.       [  make "scr-o fput :scr-x :scr-o ] 
  58.       [ ] ] 
  59.    [ not emptyp :scr-n ] 
  60.    output :scr-o ] 
  61.  
  62. ; *********************************************************************
  63. ;  edit           name
  64. ;                 name-list
  65. ;     Edit the contents of named variables. You may replace "qed" with the
  66. ;     name of the text editor of your choice.
  67.  
  68. make "edit [ 
  69.    procedure [ [ :scr-n ] ] 
  70.    prosave "ram:LOGO-workspace :scr-n 
  71.    doscommand [ qed ram:LOGO-workspace ] 
  72.    load "ram:LOGO-workspace ] 
  73.  
  74. ; *********************************************************************
  75. ;  end
  76. ;     Closes all files, windows, and screens, returns to toplevel.
  77.  
  78. make "end [
  79.    procedure [ ]
  80.    while [ not emptyp filelist ] [ close first filelist ]
  81.    while [ not emptyp screenlist ] [ closescreen first screenlist ]
  82.    while [ not emptyp windowlist ] [ closewindow first windowlist ]
  83.    while [ not emptyp system 6 ] [ ( system 5 first system 6 ) ]
  84.    recycle
  85.    toplevel ]
  86.  
  87. ; *********************************************************************
  88. ;  filter         list list
  89. ;     Output list of all items in the second list except the items that are
  90. ;     in the first list.
  91.  
  92. make "filter [
  93.    procedure [ [ :r :f ] [ ] [ :o ] ]
  94.    while [ not emptyp :f ]
  95.    [  if memberp first :f :r
  96.       [ ]
  97.       [  make "o fput first :f :o ]
  98.          make "f bf :f ]
  99.    output reverse :o ]
  100.  
  101. ; *********************************************************************
  102. ;  ignore         object (...)
  103. ;     Does nothing. Ignores the output of an operation.
  104.  
  105. make "ignore [ procedure [ [ :i1 ] :i2 ] ]
  106.  
  107. ; *********************************************************************
  108. ;  initmenu
  109. ;     Set up the command window menus and demons.
  110.  
  111. make "com-menu [  \ \ \ LOGO\ \ \ \ \ 
  112.                   [ \ Load L ]
  113.                   [ \ Save    [ \ Names N ]
  114.                               [ \ Procs P ]
  115.                               [ \ All A ] ]
  116.                   [ \ Interrupt I ]
  117.                   [ \ Top\ Level T ]
  118.                   [ \ End E ]
  119.                   [ \ Restart R ]
  120.                   [ \ Quit Q ] ]
  121.  
  122. make "initmenu [
  123.    procedure [ ]
  124.    whenmenu [ domenu getmenu ]
  125.    setmenu @0 :com-menu ]
  126.  
  127. make "domenu [
  128.    procedure [ [ :scr-menu ] [ ] [ :scr-sub ] ]
  129.    if = @0 first :scr-menu
  130.    [  if = 1 item 2 :scr-menu
  131.       [ do-com-menu :scr-menu ]
  132.       [  if and   procedurep "more-menus
  133.                   not = 0 item 2 :scr-menu
  134.          [  more-menus :scr-menu ]
  135.          [ ] ] ]
  136.    [  if procedurep "window-menus
  137.       [  window-menus :scr-menu ]
  138.       [ ] ] ]
  139.  
  140. make "do-com-menu [
  141.    procedure [ [ :scr-menu ] [ ] [ :scr-sub ] ]
  142.    make "scr-sub item 4 :scr-menu
  143.    make "scr-menu item 3 :scr-menu
  144.    cond
  145.    [  [ = 1 :scr-menu ]
  146.       [  pr [ ]
  147.          type "LOADING\ FILE
  148.          make "scr-menu ( filerequest "Load\ File\ \ -\  )
  149.          if emptyp :scr-menu
  150.          [  pr "CANCELED ]
  151.          [  type :scr-menu
  152.             load :scr-menu
  153.             pr "LOADED ]
  154.          type "? ]
  155.       [ = 2 :scr-menu ]
  156.       [  pr [ ]
  157.          type "SAVING\ FILE
  158.          make "scr-menu ( filerequest "Save\ File\ \ -\  )
  159.          if emptyp :scr-menu
  160.          [  pr "CANCELED ]
  161.          [  type :scr-menu
  162.             cond
  163.             [  [ = 1 :scr-sub ]  [ prosave :scr-menu names ]
  164.                [ = 2 :scr-sub ]  [ prosave :scr-menu procs ]
  165.                [ = 3 :scr-sub ]  [ prosave :scr-menu all ] ]
  166.             pr "SAVED ]
  167.          type "? ]
  168.       [ = 3 :scr-menu ]  [ interrupt ]
  169.       [ = 4 :scr-menu ]  [ toplevel ]
  170.       [ = 5 :scr-menu ]  [ end ]
  171.       [ = 6 :scr-menu ]  [ restart ]
  172.       [ = 7 :scr-menu ]  [ quit ] ] ]
  173.  
  174. ; *********************************************************************
  175. ;  interupt
  176. ;     A LOGO command shell that may be run from within other procedures.
  177.  
  178. make "interrupt [
  179.    procedure [ [ ] [ ] [ :scr-list ] ]
  180.    pr "INTERRUPT
  181.    while [ not memberp "cont :scr-list ]
  182.    [  catch "error [
  183.       while [ type "-->  make "scr-list rl  not memberp "cont :scr-list ]
  184.       [  run :scr-list ]
  185.       stop ]
  186.    poerror ] ]
  187.  
  188. ; *********************************************************************
  189. ;  link           name
  190. ;     Output list of all procedures needed to run the named procedure.
  191.  
  192. make "link [
  193.    procedure [ [ :proc-name ] [ ] [ :link-list ] ]
  194.    if procedurep :proc-name
  195.    [  make "link-list se :proc-name [ ]
  196.       linksub bf bf thing :proc-name ]
  197.    [  ( pr :proc-name [ is not a procedure ] ) output [ ] ]
  198.    output :link-list ]
  199.  
  200. make "linksub [
  201.    procedure [ [ :proc-list ] [ ] [ :lfirst ] ]
  202.    if emptyp :proc-list [ stop ] [ ]
  203.    make "lfirst first :proc-list
  204.    cond
  205.    [  [  listp :lfirst ]   [ linksub :lfirst ]
  206.       [  procedurep :lfirst ]
  207.       [  if memberp :lfirst :link-list
  208.          [ ]
  209.          [  make "link-list fput :lfirst :link-list
  210.             linksub bf bf thing :lfirst ] ] ]
  211.    linksub bf :proc-list stop ]
  212.  
  213. ; *********************************************************************
  214. ;  names
  215. ;     Output list of unburied names bound to something other than
  216. ;     procedures.
  217.  
  218. make "names [ 
  219.    procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
  220.    make "scr-n namelist 
  221.    dowhile 
  222.    [  make "scr-x first :scr-n 
  223.       make "scr-n bf :scr-n 
  224.       if (  or primitivep :scr-x 
  225.             procedurep :scr-x 
  226.             if > 4 count :scr-x 
  227.             [  false ] 
  228.             [  = "scr- items 1 4 :scr-x ] ) 
  229.       [ ] 
  230.       [  make "scr-o fput :scr-x :scr-o ] ] 
  231.    [ not emptyp :scr-n ] 
  232.    output :scr-o ] 
  233.  
  234. ; *********************************************************************
  235. ;  procs
  236. ;     Output list of unburied names bound to procedures.
  237.  
  238. make "procs [ 
  239.    procedure [ [ ] [ ] [ :scr-n :scr-x :scr-o ] ] 
  240.    make "scr-n namelist 
  241.    dowhile 
  242.    [  make "scr-x first :scr-n 
  243.       make "scr-n bf :scr-n 
  244.       if procedurep :scr-x 
  245.       [  make "scr-o fput :scr-x :scr-o ] 
  246.       [ ] ] 
  247.    [ not emptyp :scr-n ] 
  248.    output :scr-o ] 
  249.  
  250. ; *********************************************************************
  251. ;  prosave        file-name name
  252. ;                 file-name name-list
  253. ;     Save names, their bindings, and their protection (bury) status to
  254. ;     file.
  255.  
  256. make "prosave [ 
  257.    procedure [ [ :scr-fn :scr-n ] [ ] [ :scr-b :scr-fp ] ] 
  258.    if listp :scr-n 
  259.    [  make "scr-b justburied :scr-n ] 
  260.    [  if buriedp :scr-n 
  261.       [  make "scr-b se :scr-n [ ] ] 
  262.       [  make "scr-b [ ] ] ] 
  263.    if emptyp :scr-b 
  264.    [  save :scr-fn :scr-n ] 
  265.    [  make "scr-fp open :scr-fn 
  266.       catch "error 
  267.       [  fprint :scr-fp [ ] 
  268.          fprint :scr-fp [ ] 
  269.          ( fshow :scr-fp "unbury :scr-b ) 
  270.          fprint :scr-fp [ ] 
  271.          fprintout :scr-fp :scr-n 
  272.          fprint :scr-fp [ ] 
  273.          ( fshow :scr-fp "bury :scr-b ) 
  274.          fprint :scr-fp [ ] ] 
  275.       close :scr-fp ] ] 
  276.  
  277. make "justburied [ 
  278.    procedure [ [ :scr-n ] [ ] [ :scr-x :scr-o ] ] 
  279.    dowhile 
  280.    [  make "scr-x first :scr-n 
  281.       make "scr-n bf :scr-n 
  282.       if buriedp :scr-x 
  283.       [  make "scr-o fput :scr-x :scr-o ] 
  284.       [ ] ] 
  285.    [ not emptyp :scr-n ] 
  286.    output :scr-o ] 
  287.  
  288. ; *********************************************************************
  289. ;  restart
  290. ;     Closes windows, screens, and files, erases all but startup-stuff.
  291. ;     Restores LOGO to startup condition.
  292.  
  293. make "restart [
  294.    procedure [ ]
  295.    setmenu @0 [ ]
  296.    whenclose [ ]
  297.    whenmenu [ ]
  298.    whenmouse [ ]
  299.    whenchar [ ]
  300.    if buriedp "startup-stuff
  301.    [  erase filter :startup-stuff all
  302.       initmenu
  303.       end ]
  304.    [  erase namelist
  305.       erase burylist
  306.       recycle
  307.       toplevel ] ]
  308.  
  309. ; *********************************************************************
  310. ;  reverse        object ( object )
  311. ;     Reverse the order of the items in the object.
  312.  
  313. make "reverse [ 
  314.    procedure [ [ :from ] [ :into ] ]
  315.    if emptyp :into
  316.    [  if wordp :from
  317.       [  make "into "  ] [ ] ] [ ]
  318.    if emptyp :from
  319.    [  output :into ]
  320.    [  output  ( reverse  bf :from  fput first :from :into ) ] ]
  321.  
  322. ; *********************************************************************
  323. ;  sort           test list
  324. ;     Sort list according to test. Where "test" is the compare operation.
  325. ;  sort "alphap all
  326. ;  sort [ not alphap ] all
  327.  
  328. make "sort [
  329.    procedure [ [ :comparep :ra ] [ ] [ :n :l :j :ir :i :rra ] ]
  330.    make "comparep ( se  [ procedure [ [ :a :b ] ] output ]
  331.                         :comparep
  332.                         [ :a :b ] )
  333.    make "n count :ra
  334.    make "ra se :ra [ ]
  335.    make "l + 1 int / :n 2
  336.    make "ir :n
  337.    while [ true ]
  338.    [  if > :l 1
  339.       [  make "l - :l 1
  340.          make "rra item :l :ra ]
  341.       [  make "rra item :ir :ra
  342.          repitem :ir :ra item 1 :ra
  343.          make "ir - :ir 1
  344.          if = :ir 1 
  345.          [  output fput :rra bf :ra ] [ ] ]
  346.       make "i :l
  347.       make "j * 2 :l
  348.       while [ >= :ir :j ]
  349.       [  if if    < :j :ir
  350.             [ comparep item :j :ra item + 1 :j :ra ]
  351.             [ false ]
  352.          [  make "j + 1 :j ] [ ]
  353.          if comparep :rra item :j :ra
  354.          [  repitem :i :ra item :j :ra
  355.             make "i :j
  356.             make "j + :i :j ]
  357.          [  make "j + 1 :ir ] ]
  358.       repitem :i :ra :rra ] ]
  359.  
  360. ; *********************************************************************
  361. ;  turtle         ( bit-planes )
  362. ;     Prepare screen, window, and turtle for simple turtle graphics.
  363.  
  364. make "turtle [
  365.    procedure [ [ ] [ :d ] ]
  366.    if numberp :d [ ] [ make "d 1 ]
  367.    ( intuition 6 @0 )
  368.    recycle
  369.    make "s1 ( openscreen 3 :d [ turtle ] )
  370.    make "w1 openwindow :s1
  371.    make "t1 openturtle :w1
  372.    setrgb :s1 0 [ 0  0  0 ]
  373.    setrgb :s1 1 [ 14 14 14 ]
  374.    ( intuition 2 @0 0 0 )
  375.    ( intuition 8 @0 550 54 )
  376.    if < 300 peek -2 psum peek 0 :s1 14
  377.    [  ( intuition 1 @0 0 350 ) ]
  378.    [  ( intuition 1 @0 0 150 ) ]
  379.    ( intuition 6 @0 ) ]
  380.  
  381. ; *********************************************************************
  382. ;  vpr            object
  383. ;     Print out contents of lists verticaly.
  384.  
  385. make "vpr [
  386.    procedure [ [ :l ] [ :i ] ]
  387.    if emptyp :i [ make "i 0 ] [ ]
  388.    repeat :i [ type "\  ]
  389.    if listp :l
  390.    [  pr "[
  391.       while [ not emptyp :l ]
  392.       [  ( vpr first :l + 1 :i )
  393.          make "l bf :l ]
  394.       repeat :i [ type "\  ]
  395.       pr "] ]
  396.    [ pr :l ] ]
  397.  
  398. ; *********************************************************************
  399. ;  Names defined in this file.
  400.  
  401. make "startup-stuff [  e pi edit prosave allnames names
  402.    allprocs procs justburied all link linksub ignore
  403.    end reverse filter initmenu domenu do-com-menu interrupt restart
  404.    sort ppr com-menu turtle startup-stuff ] 
  405.  
  406. bury :startup-stuff
  407.  
  408. ; *********************************************************************
  409. ;  Set up the command window menus and demons.
  410.  
  411. initmenu
  412.  
  413.