1
pose-all
(method (INSTRING)
  (foreach (CON CONNECTED-LIST) 
    (CON:TELL (+ (tostr CALLER) " " INSTRING "\n"))))

/
numguests
0
/
shutdown-method
(method ()
  (begin (TELL-ALL (+ "Server shutdown by " (tostr CALLER))) 
    (set CONNECTED-LIST '()) 
    (shutdown)))

/
remove-connection
(method ()
  (set CONNECTED-LIST (SET-REMOVE CALLER CONNECTED-LIST)))

/
welcome-message
"You are now connecting to the doodle core.\n"
/
boot
(method ()
  (set CONNECTED-LIST '()))

/
parse
(method (INSTRING)
  (echo "Please wait while your connection is transfered.\n"))

/
tell-all
(method (INSTRING)
  (foreach (CON CONNECTED-LIST) 
    (CON:TELL (+ (tostr CALLER) " says, \"" INSTRING "\"\n"))))

/
connect
(method ()
  (var ONUM 
    (begin (echo WELCOME-MESSAGE) (set ONUM (#2:COPY)) 
      (TELL-ALL (+ (tostr ONUM) " has connected.")) 
      (set CONNECTED-LIST (SET-ADD ONUM CONNECTED-LIST)) 
      (echo (+ "Connecting you to Object " (tostr ONUM) "\n")) 
      (echo "Objects currently connected:") 
      (foreach (I CONNECTED-LIST) (echo (+ " " (tostr I)))) 
      (echo "\n") 
      (echo "Have a swell time.\n") 
      (reconnect #0 ONUM) 
      (ONUM:TELL "Successfully reconnected\n"))))

/
connected-list
'()
/
/
/+++++++++++++ end of object #0 +++++++++++++

after-cut
(method (DIVIDER INSTRING)
  (var FOUND-AT 
    (begin (set FOUND-AT (search DIVIDER INSTRING)) 
      (if (and FOUND-AT (< FOUND-AT (length INSTRING))) 
        (range (+ FOUND-AT 1) (length INSTRING) INSTRING) 
        
        ""))))

/
set-add
(method (ELEM INLIST)
  (if (not (search ELEM INLIST)) (insert ELEM INLIST 1) INLIST))

/
set-remove
(method (ELEM INLIST)
  (var I 
    (begin (set I (search ELEM INLIST)) 
      (if (or (not I) (not INLIST)) INLIST 
        (if (= 1 (length INLIST)) '() 
          (if (= I (length INLIST)) (range 1 (- I 1) INLIST) 
            (if (= I 1) (range 2 (length INLIST) INLIST) 
              (+ (range 1 (- I 1) INLIST) 
                (range (+ I 1) (length INLIST) INLIST)))))))))

/
~test-priv
(method ()
  (PLAYER:TELL "testing"))

/
tell
(method (INSTRING)
  (ignore 26 (or (echo INSTRING) "")))

/
add-variable
(method (SYMBOL VALUE)
  (ADDVAR SYMBOL VALUE))

/
list-variables
(method ()
  (vars))

/
descends-from?
(method (ANC)
  (foreach (PARENT (parents)) 
    (if (or (= PARENT ANC) (PARENT:DESCENDS-FROM? ANC)) (return 1))))

/
dump-to-string
(method ()
  (+ (+ "Object ID: " (tostr THIS) "\n") 
    (+ "Parents:   " (tostr (parents)) "\n") 
    (if (not (= CALLER THIS)) "The rest of the object is not available\n" 
      (+ "Vars:      " (tostr (vars)) "\n" "Commands:  " (tostr (commands)) 
        
        "\n"))))

/
copy
(method ()
  (clone))

/
/
/+++++++++++++ end of object #1 +++++++++++++
0 1
short-pose
(method (INLINE)
  (POSE-ALL (index 2 INLINE)))

/
eval-command
(method (INLINE)
  (PLAYER:TELL 
    (+ "--> " (tostr ((compile (+ "(method () " (index 3 INLINE) ")\n")))) 
      "\n")))

/
shutdown-command
(method (UNUSED)
  (#0:SHUTDOWN-METHOD))

/
say-method
(method (INLINE)
  (TELL-ALL (index 2 INLINE)))

/
parse
(method (INSTRING)
  (if 
    (not 
      (foreach (I (matchcmd INSTRING)) (if ((car I) (index 2 I)) (return 1)))) 
    (echo "I don't understand that\n")))

/
test-cmd
(method (INLINE)
  (TELL (+ (tostr INLINE) "\n")))

/
page-command
(method (INLINE)
  (if (= (tostr THIS) (index 3 INLINE)) 
    (TELL (+ (tostr THIS) " pages: " (index 5 INLINE) "\n"))))

/
quit
(method ()
  (begin (#0:REMOVE-CONNECTION) 
    (#0:TELL-ALL (+ (tostr THIS) " has disconnected")) 
    (disconnect)))

/
quit-command
(method (UNUSED)
  (QUIT))

/
/
'("t" (or " " "est") REST)
test-cmd
'("p" (or "age" "") (or (before "=") (before "with") WORD) (or "=" "with" "") REST)
page-command
'(":" REST)
short-pose
'("\"" REST)
say-method
'("say" REST)
say-method
'("quit")
quit-command
'("shutdown")
shutdown-command
'("eval" (or "uate" "") REST)
eval-command
'(";" "" REST)
eval-command
/+++++++++++++ end of object #2 +++++++++++++
1
parse
(method (istr) (begin
	(foreach (c (matchcmd istr))
		(if (call caller (index 1 c) (index 2 c)) (return 1))
		)
	(if (= 1 (search "." istr))
		(return (tell ">> No matching .command found.  Use .h for help.\n"))
		)
	(if (= 1 (search "\\" istr))
		(set istr (after 1 istr))
		)
	(caller:edit-insert istr)
	))
/
edit-insert
(method (istr) (begin
	(set @edit-list (insert istr @edit-list @edit-ins))
	(set @edit-ins (+ 1 @edit-ins))
	))
/
edit-delete-cmd
(method (lst) (var st (var nd
	(set st (tonum (index 3 lst)))
	(if (not (index 4 lst))
		(set nd st)
		(set nd (tonum (index 4 lst)))
		)
	(if (or (< st 1) (< nd st) (> nd (length @edit-list)))
		(begin (tell ">> Bad range of numbers.\n") (return 1))
		)
	(set @edit-list (+ (before st @edit-list) (after nd @edit-list)))
	(if (> @edit-ins nd)
		(set @edit-ins (- @edit-ins (+ (- nd st) 1)))
		(if (> @edit-ins st)
			(set @edit-ins st)
			)
		)
	(tell (+ ">> " (tonum (+ (- nd st) 1)) " lines deleted, inserting at "
		(tonum @edit-ins) ".\n"
		))
	)))
/
edit-insert-cmd
(method (lst) (var ins
	(set ins (tonum (index 3 lst)))
	(if (> ins 0)
		(begin
			(if (< ins (+ 1 (length @edit-list)))
				(set ins (+ 1 (length @edit-list)))
				)
			(set @edit-ins ins)
			(tell (+ ">> Inserting at line " (tostr ins) ".\n"))
			)
		(tell ">> You cannot insert before line 1.\n")
		)
	))
/
list-edit
(method (st nm lns) (begin
	(if (not st)
		(begin
			(set st 1)
			(set nm (length @edit-list))
			)
		(begin
			(set st (tonum st))
			(if (not nm)
				(set nm 1)
				(set nm (+ (- (tonum nm) st) 1))
				)
			(if (or (< st 1) (< nm 0) (> (+ st nm) (length @edit-list)))
				(begin (tell ">> Bad range of numbers.\n") (set nm 0))
				)
			)
		)
	(dotimes (i nm) (tell (+
		(if lns (+ (tonum (+ st i -1)) ">") "")
		(index (+ st i -1) @edit-list)
		"\n"
		)))
	(tell (+ ">> " (tonum nm) " lines displayed.\n"))
	))
/
edit-list-cmd
(method (lst) (begin
	(list-edit (index 3 lst) (index 4 lst) 0)
	(return 1)
	))
/
edit-nlist-cmd
(method (lst) (begin
	(list-edit (index 3 lst) (index 4 lst) 1)
	(return 1)
	))
/
edit-quit-cmd
(method (lst) (begin
	((eval '@edit-done) @edit-old)
	(return 1)
	))
/
edit-exit-cmd
(method (lst) (begin
	((eval '@edit-done) (+ (implode "\n" @edit-list) "\n"))
	(return 1)
	))
/
edit-help-cmd
(method (lst)
	(tell (+
		">>Editor Commands:\n"
		">>  .l[ist] [#start] [#end]\n"
		">>  .n[list] [#start] [#end]\n"
		">>  .i[nsert] [#before]\n"
		">>  .d[elete] #start [#end]\n"
		">>  .q[uit]\n"
		">>  .e[xit]\n"
		">>  .h[elp]\n"
		"------------\n"
		"Format: .<command> <arg list>\n"
		"all other lines are inserted unchanged, except that if it has a\n"
		"'\' as the first character, it will be stripped first.  This is\n"
		"to allow lines with . in the beginning to be inserted, by putting\n"
		"a \ in front of it.\n"
		))
	)
/
/
'(".d" (or "elete" "") NUMBER (or NUMBER ""))
edit-delete-cmd
'(".i" (or "nsert" "") NUMBER)
edit-insert-cmd
'(".l" (or "ist" "") (or NUMBER "") (or NUMBER ""))
edit-list-cmd
'(".n" (or "list" "") (or NUMBER "") (or NUMBER ""))
edit-nlist-cmd
'(".q" (or "uit" ""))
edit-quit-cmd
'(".e" (or "xit" ""))
edit-exit-cmd
'(".h" (or "elp" ""))
edit-help-cmd
/