/* --- Copyright University of Sussex 1998. All rights reserved. ---------- > File: $poplocal/local/lib//popbugs.p > Purpose: Animat simulation environment > Author: Chris J Thornton, Feb 20 1998 > Documentation: HELP * POPBUGS > Related Files: */ vars pop_package = [popbugs fullpopbugs showdisplay showpalette]; vars pb_setup_in_progress; if pb_setup_in_progress == true then [] -> proglist endif; max(popmemlim, 400000) -> popmemlim; /* we need lots of memory */ /* cancel active vars in case user has accidently declared them */ applist([pb_caption pb_clip_file pbcp pbco pb_spec pb_specs pb_new_world pb_steps pb_turns pb_size pb_sensor_inputs pb_cycles pb_colour_display pb_current_bug pb_current_obj pb_action pb_simulation], syscancel); vars active (pb_current_bug pb_action pb_behaviour pb_clip_file pb_colour_display, pb_new_world, pb_simulation pb_background_colour); /* This should be the default anyway... */ lvars pr_quotes = pop_pr_quotes; false ->> pop_pr_ratios -> pop_pr_quotes; /* Load in showdisplay and decide whether we have a display */ loadlib("showdisplay"); vars pb_screen_display; unless isboolean(pb_screen_display) do systranslate('DISPLAY') -> pb_screen_display; endunless; unless pb_screen_display do npr('WARNING - No screen display for Bugworld'); endunless; /* Define a constructor of expanding properties - needed in vars decs */ define global newmap(list); /* expanding temp property */ lvars list gc_flag = "perm"; if isword(list) do list -> gc_flag; -> list; endif; newanyproperty(list, 16, 1, false, syshash, nonop ==, gc_flag, false, false) enddefine; vars /* assignable/accessible vars */ pb_searchlist = [], pb_max_cycles = 99999999, pb_sensor_noise = 0, pb_motor_noise = 0, pb_use_stored_sensor_inputs = true, pb_display_mapped_world = false, pb_message_font_size = 18, pb_max_turn_arc = 360, pb_max_coord = 100, /* number of points in a dimension */ pb_grid_world = false, pb_grid_line_colour = "grey", pb_grid_world_alignment = false, pb_max_distance = sqrt((pb_max_coord**2) * 2), pb_unit_length = pb_max_coord/10, pb_trail_length = 20, pb_spec_obj, /* instantiated on each assignment to pb_spec */ pb_linesize = 1, pb_wraparound = false, pb_responses = false, pb_response_filter = identfn, pb_inputs_filter = identfn, pb_outputs_filter = identfn, pb_scores, pb_scores_map, pb_scores_maxval, pb_current_criteria = false, pb_n_objects = 0, pb_n_bugs = 0, pb_clip = false, pb_write_clips = false, pb_simulation_finished = true, pb_controllers = [controller pb_advance pb_advance_randomly], pb_special_controllers = [], /* used by learnbugs */ pb_topbug_controller = "controller", /* used by learnbugs to overide normal controller */ pb_cycle_trap = identfn, pb_types = [bug obstacle], pb_special_shapes = newassoc([ [fish [{-1 0}{-0.4 -1} {0.7 -0.2}{1 -1} {1 1} {0.7 0.2}{-0.4 1}{-1 0}]] [saw [{-1 -1}{-0.75 0}{-0.5 -1}{-0.25 0}{0 -1}{0.25 0} {0.5 -1}{0.75 0}{1 -1}{1 1}{-1 1}{-1 -1}]] [fork_lift_truck [{-1 -1} {1 -1} {1 1} {-1 1} {-0.3 1} {-0.3 -1} {-1 -1}]] ]), pb_basic_shapes = [circle box ant triangle tank dalek], pb_shapes = pb_basic_shapes <> [^(appproperty(pb_special_shapes, erase))], pb_non_bug_behaviours = [static passive deathtrap], pb_substances = [air rock mist rubber], pb_impenetrable_substances = [rock rubber], pb_allow_display_updates = true, pb_display_name = 'POPBUGS Main Display', pb_showdisplay_args = [^pb_display_name], pb_chunk_showdisplay_calls = false, pb_slow_motion = false, pb_caption_position = "title_bar", pb_simulation_data = [], pb_topbug, pb_do_cycle, pb_cycle_number, pb_refresh, pb_display_update_gap = 1, pb_display_refresh_gap = 1000, pb_cycle_pause = false, pb_set_data, pb_init, pb_obj_field_map, pb_field_names, pb_field_pdrs, pb_colours = [black blue green cyan red magenta yellow /* purple aquamarine gray PowderBlue HotPink */], pb_dark_colours = sd_dark_colours, pb_pseudo_colours = [random same background transparent palette], pb_obj_with_colour = newproperty([],64,false,false), pb_available_colours = tl(pb_dark_colours), pb_colour_menu = pb_colours <> pb_pseudo_colours, pb_sim_cp_sheet = false, pb_obj_record_prefix = "pb_obj_", fullpopbugs, pb_fullenv, pb_drive_actions = {{-0.2 0.2} {0.8 0.8} {0.2 -0.2}}, pb_update_count, pb_show_obj_trap = erase, pb_unshow_obj_trap = erase, pb_score_on = false, pb_obj_selection_trap = erase, pb_show_intercept_numbers = true, pb_stored_response_input_buffer_length = false, pb_cycle_time = false, ; vars /* used for calls on matcher */ x, y, n, field, val, vals, menu, ; /* Compatibility */ if isdefined("pb_fullenv") and (not(isdefined("fullpopbugs")) or isundef(valof("fullpopbugs"))) do pb_fullenv -> fullpopbugs; endif; constant /* user accessible but not definable */ pb_right_turn = {0.2 -0.2}, pb_left_turn = {-0.2 0.2}, pb_forwards = {1 1}, pb_backwards = {-1 -1}, pb_forwards_right_turn = {1 0.5}, pb_forwards_left_turn = {0.5 1}, pb_forwards_hard_right_turn = {1 0.2}, pb_forwards_hard_left_turn = {0.2 1}, pb_stay_still = {0 0}, pb_standard_wheel_rotations = [pb_forwards pb_forwards_right_turn pb_forwards_left_turn pb_forwards_hard_right_turn pb_forwards_hard_left_turn pb_right_turn pb_left_turn pb_stay_still], ; vars /* lvars */ /* file-locals */ object_map = newmap([]), obstruction_encountered = false, sd_comms = [], compulsory_colour = false, compulsory_shape = false, compulsory_position = false, update_simulation, updates_record = false, world_initialized = false, world_displayed = false, current_bug = false, bug_initiating_move = false, current_obj = false, intersection_object_colour, display_level = false, misc_env_vars = [], sim_name = nullstring, sim_pdrs = newmap([]), max_event_number = 256, events = consvector(repeat max_event_number times false endrepeat, max_event_number), new_event_number = 1, current_event_number = 1, current_selection = {^false ^false ^false ^false ^false}, last_selection = false, palette_selection = false, palette_display_name = 'POPBUGS colour palette', sim_cp_box = false, obj_cp_box = false, obj_cp_sheet = false, obj_cp_sheet_obj_num = false, obj_cp_sheet_attributes = [ [number menuof [^nullstring 1 2]] [name ^nullstring] [type menuof ^(nullstring :: pb_types)] [shape menuof ^(nullstring :: pb_shapes)] [colour menuof ^(nullstring :: pb_colour_menu)] [trail_colour menuof ^(nullstring :: pb_colour_menu)] [label ^nullstring] [boundary menuof [^nullstring ^^pb_substances]] [innards menuof [^nullstring ^^pb_substances]] [direction 0-360] [position ^nullstring] [dimensions ^nullstring] [sensors ^nullstring] [behaviour ^nullstring] [tracklength '0.8'] [mass 0-250] [display_level oneof [1 2 3 4 5]]], ; vars /* forward declaration of global procedures */ ved_pb, pb_set_data, pb_new_obj, pb_clear_move_to, pb_show_obj, pb_attempt_wheel_rotations, pb_unshow_obj, pb_unshow_obj, pb_distance_between, pb_direction_towards, pb_apply_and_store = popval, /* overriden below */ pb_show_message, pb_show_scores, pb_datafile, pb_is_bug, pb_show_caption, pb_obstruction_at, pb_show_obj_boundary_in, pb_state_after_wheel_rotations, pb_possible_move, pb_score_on, pb_show_all_objects, pb_possible_move, pb_attempt, pb_coords_out_of_bugworld, pb_set_val, ; vars /* lconstant */ /* forward declarations of lconstant pdrs */ get_ray_between, get_obj_colour, get_obj_dimensions, normalise_move, init_display, update_obj_cp, update_sim_cp, set_obj_cp, event_handler, init_palette, respond_to_new_event, ; /* A procedure to set up record definitions with automatic defaults */ define /* lconstant */ make_class(prefix, list); lvars x w field_map_var = consword(prefix sys_>< 'field_map'), prefix list obj name = prefix; dlocal field vals; dlocal pop_pr_quotes = false; if last(prefix) == `_` then allbutlast(1, prefix) -> name endif; popval([ defclass ^name ^("{") ^(for x in list do consword(prefix >< hd(x)); ","; endfor ->) ^("}") ; vars ^(consword('consdefault'>< 'attribute_vals')); ]); newmap([]) -> valof(field_map_var); foreach [?field = ?vals] in list do {^vals ^(consword(prefix >< field))} -> valof(field_map_var)(field); endforeach; procedure -> obj; lvars obj; valof(consword('cons' >< name))( applist(list, procedure(x); if isprocedure(x(2) ->> x) then x() else x endif endprocedure)) -> obj; endprocedure -> valof(consword('consdefault'> result; lvars x pred, result = false; unless pred(x) do pred -> result endunless; enddefine; define /* lconstant */ illegal_coords(x) -> result; lvars x, result = false; unless (isvector(x) or islist(x)) and length(x) fi_>= 2 and isnumber(x(1)) and isnumber(x(2)) do '{ }' -> result; endunless; enddefine; define /* lconstant */ illegal_colour(c) -> result; lvars c i, result = false; if isvector(c) then c(1) -> c endif; unless isword(c) or fast_subscrs(1, c) == `#` do pb_colours -> result; endunless; enddefine; define /* lconstant */ illegal_behaviour(b) -> result; lvars b, v, result = false; unless (b == "active" or fast_lmember(b, pb_non_bug_behaviours)) or (islist(recursive_valof(b) ->> b) and length(b) == 2) or isproperty(b) and isprocedure(recursive_valof(b("action"))) or not(illegal_coords(b)) or isprocedure(b) do '' -> result; endunless; enddefine; define /* lconstant */ illegal_member(x,l) -> result; lvars x l, result = false; unless fast_lmember(x, l) do l -> result endunless; enddefine; define /* lconstant */ illegal_shape(x) -> result; lvars x, result = false; if not(ispair(x)) do illegal_member(x, pb_shapes) -> result; endif; enddefine; define /* lconstant */ illegal_list_or_int(x) -> result; lvars x, result = false; unless islist(x) or isinteger(x) do ' or ' -> result; endunless; enddefine; define /* lconstant */ islistorint(x); lvars x; islist(x) or isinteger(x) enddefine; make_class(pb_obj_record_prefix, [ /* field-name initial val checking-pdr */ [number ^false ^false] [name ^false ^false] [type ^false ^false] [position ^false ^illegal_coords] [dimensions ^false ^illegal_coords] [boundary rock ^(illegal_member(%pb_substances%))] [innards rock ^(illegal_member(%pb_substances%))] [shape ^false ^illegal_shape] [behaviour static ^illegal_behaviour] [tracklength 0.8 ^(illegal_obj(%isnumber%))] [direction ^false ^(illegal_obj(%isnumber%))] [display_level 1 ^(illegal_member(%[1 2 3 4 5]%))] [colour ^false ^illegal_colour] [label ^false ^(illegal_obj(%isstring%))] [trail_colour ^false ^illegal_colour] [sensors ^false ^(illegal_obj(%islist%))] [sensor_places ^false ^(illegal_obj(%isnumber%))] [blind_spots ^false ^(illegal_obj(%islist%))] [mass 0 ^(illegal_obj(%isnumber%))] [depth 0 ^(illegal_obj(%isinteger%))] [update_trap ^false ^false] /* attributes used for storage of derived data */ [action_data ^false ^false] [direction_data ^false ^false] [edge_data ^false ^false] [ray_sensor_data ^(newmap(%[]%)) ^false] [sensed_data ^(newmap(%[]%)) ^false] [sensor_inputs_data ^(initv(%2%)) ^false] [data ^(newmap(%[]%)) ^false] [trail_data ^(newassoc(%[]%)) ^false] [display_data ^false ^false] ]); [% appproperty(pb_obj_field_map, procedure(f,v); lvars f v; v(2) endprocedure) %] -> pb_field_pdrs; [% appproperty(pb_obj_field_map, procedure(f,v); lvars f v; f endprocedure) %] -> pb_field_names; /* -- Basic utilities ------------------------------ */ define pb_pr; vedputmessage() enddefine; define /* lconstant */ min_&_max(mn,mx); lvars mn mx; if mn fi_> mx then mn, mx else mx, mn endif; enddefine; define /* lconstant */ round_to(n, places); lvars m result; lconstant mults = newassoc([[0 1][1 10][2 100][3 1000][4 10000][5 100000][6 1000000]]); mults(places) -> m; if isinteger(n) then n else number_coerce(round(n * m) / m, n) endif; enddefine; define pb_do_interrupt; interrupt(); enddefine; define active pb_simulation; sim_name; enddefine; define /* lconstant */ caption_for(simulation, controller); lvars simulation controller; dlocal pop_pr_quotes = false; unless controller do "controller" -> controller endunless; consword(simulation >< '-by-' >< controller); enddefine; define active pb_driven_bug; current_selection(4); enddefine; define cancel_current_selection; current_selection(1) -> last_selection; fill(repeat length(current_selection) times false endrepeat, current_selection) ->; enddefine; define active pb_caption; if pb_driven_bug then 'DRIVING in ' sys_>< pb_simulation sys_>< ' simulation' elseif pb_simulation /= nullstring do caption_for(pb_simulation, pb_topbug_controller) else nullstring endif; enddefine; define /* lconstant */ add_noise(vec, level) -> vec; lvars vec = copy(vec), v, n, i; if level /== 0 do for i from 1 to length(vec) do vec(i) + (random(level*2)-level) -> vec(i); endfor; endif; enddefine; define pb_simulation_names; lvars d, rep l = [], f; sort( [% appproperty(sim_pdrs, erase); for d in pb_searchlist do if sysisdirectory(d) then sys_file_match(d dir_>< '*.p','',false,false) -> rep; until (rep() ->> f) == termin do consword(sys_fname_nam(f)) -> f; unless sim_pdrs(f) do f endunless; enduntil; endif; endfor % ]); enddefine; define pb_simulations; sim_pdrs(); enddefine; define updaterof pb_simulations(vec, wd); lvars vec wd; if pb_sim_cp_sheet and not(sim_pdrs(wd)) then vec -> sim_pdrs(wd); valof("propsheet_field")(pb_sim_cp_sheet, [[simulation menuof ^(nullstring :: pb_simulation_names()) (default = ^(wd sys_>< nullstring))]]); else vec -> sim_pdrs(wd); endif; wd -> sim_name; enddefine; define /* lconstant */ get_simulation_pdr(tag) -> pdr; lvars tag, pdr = false, pdrs, i; lconstant vec = {0}, map = newassoc([[init 1][update 2]]); if (pb_simulations(pb_simulation) ->> pdrs) then unless islist(pdrs) or isvector(pdrs) do pdrs -> vec(1); vec -> pdrs; endunless; if length(pdrs) >= (map(tag)->>i) then pdrs(i) else false endif-> pdr; recursive_valof(pdr) -> pdr; endif; enddefine; define updaterof active pb_simulation; lvars f; dlocal pb_setup_in_progress = true; -> sim_name; if not(pb_simulations(sim_name)) and (syssearchpath(pb_searchlist, sim_name sys_>< '.p') ->> f) then compile(f); if not(pb_simulations(sim_name)) then mishap('Simulation file does not update pb_simulations', [^f]); endif; endif; if pb_simulation_finished then pb_init(); endif; enddefine; define /* lconstant */ copy_major_fields(obj1, obj2); lvars obj1 obj2 pdr f; lconstant pdrs = pb_field_pdrs; for pdr in pdrs do nextif(issubstring('_data', pdr)); valof(pdr) -> f; f(obj1) -> f(obj2); endfor; enddefine; define pb_nodups(list); lvars l, list item; [% for l on list do unless member(hd(l), tl(l)) then hd(l) endunless endfor %] enddefine; /* -- Objects ------------------ */ define pb_map(); object_map(); enddefine; define updaterof pb_map(v, i); lvars v i, obj; if updates_record then pb_map(i) -> obj; conspair([[^obj -> pb_map(^i)][^v -> pb_map(^i)]], updates_record("pb_map")) -> updates_record("pb_map"); endif; v -> object_map(i); enddefine; define pb_objects_with(att, val); lvars i att val, obj, v; [% for i from 1 to pb_n_objects do nextunless(pb_map(i) ->> obj); if ((att(obj) ->> v) and val == false) or (val and v = val) then obj endif; endfor %] enddefine; define pb_is_obstacle(obj); lvars ob, b; ispb_obj(obj) and (fast_lmember(pb_obj_behaviour(obj) ->> b, pb_non_bug_behaviours) or isstring(b)) enddefine; define pb_is_bug(obj); lvars obj; ispb_obj(obj) and not(pb_is_obstacle(obj)); enddefine; vars pb_isobj = ispb_obj; define pb_get_obj(i, type); lvars i, l; if isword(i) then pb_objects_with(pb_obj_name, i); elseif isprocedure(type) then pb_objects_with(type, false); elseif isinteger(i) then pb_objects_with(pb_obj_type, type) else pb_objects_with(pb_obj_name, i) endif -> l; /* take account of bugworld being first obstacle */ unless isinteger(i) do 1 -> i endunless; if type == "obstacle" then i + 1 -> i endif; if length(l) >= i then l(i) else false endif; enddefine; define pb_bug(/* i */); pb_get_obj(/* i */ pb_is_bug) enddefine; define pb_obs(/* i */); pb_get_obj(/* i */ pb_is_obstacle) enddefine; define pb_obj_called( /* name */); pb_get_obj(false) enddefine; /* -- Object properties ---------------------------- */ define get_tracklength(bug) -> tracklength; lvars bug, tracklength = pb_obj_tracklength(bug); if isdecimal(tracklength) then pb_obj_dimensions(bug)(2) * tracklength -> tracklength endif; enddefine; define /* lconstant */ get_col_&_fill(obj) -> (c, f); lvars c c1 f, innards = pb_obj_innards(obj) ; lconstant filled = [#]; if compulsory_colour ->> c1 then c1 else pb_obj_colour(obj) endif -> c; if innards == "air" then [] else filled endif -> f; if c == "background" then pb_background_colour -> c endif; if c == "palette" and isvector(palette_selection) then palette_selection(1) -> c endif; enddefine; define /* lconstant */ get_obj_colour(obj) -> c; lvars obj,c; get_col_&_fill(obj) -> (c, ); enddefine; define /* lconstant */ get_real_colour(col) -> col; lvars col; if ispb_obj(col) then pb_obj_colour(col) -> col endif; enddefine; define /* lconstant */ get_obj_sensor_places(obj) -> places; lvars obj, places = pb_obj_sensor_places(obj); unless places do 3 -> places endunless; enddefine; define pb_colour_code(c); lvars code, places; if ispb_obj(c) then get_obj_sensor_places(c) -> places; -> c endif; syshash(get_real_colour(c)) -> code; if code then round_to(code / 10000, 3) else -1 endif enddefine; define pb_colour_of_code(code) -> col; lvars code, c, col = false; lconstant map = newassoc([]); if not(map(code) ->> c) then for c in sd_colours do if pb_colour_code(c) = code then c ->> col -> (code);quitloop endif; endfor; endif; enddefine; define global ved_pbcol; dlocal pop_pr_ratios = false; pb_colour_code(consword(vedargument)); enddefine; define /* lconstant */ get_obj_colour_val(obj); pb_colour_code(get_obj_colour(obj)) enddefine; define active pb_background_colour; if pb_obj_innards(pb_map(1)) == "air" then "white" else pb_obj_colour(pb_map(1)) endif enddefine; define /* lconstant */ get_obj_shape(obj); lvars obj s; if compulsory_shape ->> s then s else pb_obj_shape(obj) endif; enddefine; define /* lconstant */ get_obj_display_level(obj); if display_level then display_level else pb_obj_display_level(obj); endif; enddefine; define /* lconstant */ get_obj_trail_colour(obj) -> col; lvars obj, col = pb_obj_trail_colour(obj), main_col = get_obj_colour(obj); lconstant random_cols = pb_dark_colours; if col == "random" then valof("oneof")(random_cols) -> col endif; if col == "same" then get_obj_colour(obj) -> col; endif; if col == "background" then pb_background_colour -> col endif; if col == "palette" and isvector(palette_selection) then palette_selection(1) -> col endif; unless col do "white" -> col endunless; enddefine; define /* lconstant */ get_obj_dimensions(obj); lvars obj; pb_obj_dimensions(obj); enddefine; /* -- Geometry ------------------------------------- */ define pb_distance_between(obj1, obj2); lvars pos2 pos1 obj1 obj2, y1, x1 c2 x2, y2; if isvector(obj1) or islist(obj1) do obj1 else pb_obj_position(obj1) endif -> pos1; if isvector(obj2) or islist(obj2) do obj2 else pb_obj_position(obj2) endif -> pos2; unless pos1 and pos2 do return(pb_max_coord) endunless; explode(pos1) -> y1 -> x1; explode(pos2) -> y2 -> x2; sqrt(((x2-x1) ** 2) + ((y2-y1) **2)); enddefine; /* Angle 0 is due west. Clockwise changes are positive */ define pb_angle_between(d1, d2) -> a; lvars a d1 = intof(d1) fi_+ 360, d2 = intof(d2) fi_+ 360; d1 fi_- d2 -> a; if a fi_> 180 then -(360 fi_- a)->a elseif a < -180 then 360 fi_+ a -> a endif; enddefine; define pb_direction_towards(pb1, pb2) -> direction; lvars pb1 pb2, x1,y1,x2,y2,pos1, pos2 direction; if isvector(pb1) do pb1 else pb_obj_position(pb1) endif -> pos1; if isvector(pb2) do pb2 else pb_obj_position(pb2) endif -> pos2; intof(subscrv(1, pos1)) -> x1; intof(subscrv(2, pos1)) -> y1; intof(subscrv(1, pos2)) -> x2; intof(subscrv(2, pos2)) -> y2; arctan2((x2 fi_- x1), -(y2 fi_- y1)) + 180 -> direction; enddefine; define pb_rotated_coords(x,y,xc,yc,obj) -> (X, Y); lvars x y d, xc, yc, X, Y, n = pb_max_coord, SIN COS, v, d, d1 = false, params; if isnumber(obj) then sin(obj) -> SIN; cos(obj) -> COS; elseif (pb_obj_direction(obj) -> d, pb_obj_direction_data(obj) -> params, not(isvector(params))) or (destvector(params) -> -> d1 -> COS -> SIN, d /== d1) then d mod 360 ->> d -> pb_obj_direction(obj); {%sin(d) ->> SIN, cos(d) ->> COS, d%} -> pb_obj_direction_data(obj); endif; if d1 and d == 0 then x -> X; y -> Y; return endif; ((x-xc) * COS) + ((y-yc) * SIN) + xc -> X; - ((x-xc) * SIN) + ((y-yc) * COS) + yc -> Y; /* round_to(X, 1) -> X; round_to(Y, 1) -> Y; */ enddefine; define /* lconstant */ get_rotated_coords -> y -> x; /* same as above but reverses outputs */ lvars x y; pb_rotated_coords() -> (x, y); enddefine; define pb_offset_pos(pos, dir, dis) -> pos; lvars pos, dir, dis, x1 = pos(1), y1 = pos(2); {% pb_rotated_coords(x1-dis,y1,x1,y1,dir) %} -> pos; enddefine; /* -- Generating random positions ------------------ */ define pb_find_empty_pos(pos1, dis) -> pos2; lvars pos1 pos2,dis, x,y, x1, y1, obj = false, obj_i = false, dir; if pb_isobj(pos1) do pos1 -> obj; -> pos1; pb_obj_number(obj) -> obj_i; endif; explode(pos1) -> (x,y); random(360) -> dir; repeat 72 times dir + 5 mod 360 -> dir; {% pb_rotated_coords(x-dis,y,x,y,dir) %} -> pos2; if not(pb_coords_out_of_bugworld(pos2)) and not(pb_obstruction_at(obj_i, pos2)) then return; endif; endrepeat; false -> pos2; enddefine; define pb_find_empty_pos_inside(margin); lvars margin; pb_find_empty_pos({50 50}, random(50-margin)) enddefine; define pb_random_pos; {% random(100), random(100) %}; enddefine; vars pb_random_pos_at_distance = pb_find_empty_pos, pb_random_pos_within = pb_find_empty_pos_inside; /* -- Corner coordinates ---------- */ define /* lconstant */ obj_width(obj); lvars obj; pb_obj_dimensions(obj)(1) enddefine; define /* lconstant */ obj_length(obj); lvars obj; pb_obj_dimensions(obj)(2) enddefine; define /* lconstant */ corner(obj, xop, yop) -> (x, y); lvars arg, x y, xop yop obj, pos dims x y; if isvector(obj) then obj -> pos; -> obj; else pb_obj_position(obj) -> pos endif; get_obj_dimensions(obj) -> dims; xop(pos(1), (dims(1)/2)) -> x; yop(pos(2),(dims(2)/2)) -> y; pb_rotated_coords(x,y,pos(1), pos(2), obj) -> (x, y); enddefine; define pb_frontright; corner(nonop -, nonop -); enddefine; define pb_frontleft; corner(nonop -, nonop +); enddefine; define pb_backleft; corner(nonop +, nonop +) enddefine; define pb_backright; corner(nonop +, nonop -) enddefine; define pb_backmid; corner(nonop +, erase); enddefine; define pb_frontmid; corner(nonop -, erase); enddefine; define pb_midright; corner(erase, nonop +); enddefine; define pb_midleft; corner(erase, nonop -); enddefine; define /* lconstant */ obj_corners(obj) -> (fr, fl, bl, br, fr); lvars obj, pos, fr br, fl, bl; if isvector(obj) then obj->pos; -> obj; else pb_obj_position(obj) -> pos; endif; {% pb_frontright(obj, pos) %} -> fr; {% pb_backright(obj, pos) %} -> br; {% pb_frontleft(obj, pos) %} -> fl; {% pb_backleft(obj, pos) %} -> bl; enddefine; define obj_extreme_points(obj); lvars obj; define vars pb_rotated_coords(x,y,a,b,c) -> (x,y); lvars x,y,a,b,c; enddefine; obj_corners(obj); enddefine; define /* lconstant */ obj_outline_points(obj, outline) -> points; lvars pos = pb_obj_position(obj), outline, x = pos(1), y = pos(2), p, x1, y1, dims = pb_obj_dimensions(obj), xd = dims(1)/2, yd = dims(2)/2, v, fr = false, points; {% for p in outline do pb_rotated_coords(x+(p(1)*xd),y+(p(2)*yd),x,y,obj) -> (x1, y1); {^x1 ^y1}; endfor %} -> points; points(1) -> last(points); /* last must be _identical_ to first */ enddefine; define /* lconstant */ obj_vertices(obj) -> vertices; lvars obj, pos = pb_obj_position(obj), x = pos(1), y = pos(2), shape = pb_obj_shape(obj), vertices, outline_points, v;; if (pb_special_shapes(shape) ->> outline_points) then obj_outline_points(obj, outline_points) -> vertices; else /* get corners for standard box-shape */ consvector(#| obj_corners(obj, pb_obj_position(obj)) |#) -> vertices; endif; enddefine; define /* lconstant */ same_situation(obj, pos, old_data); lvars obj, old_data, pos, d = pb_obj_direction(obj), dims = pb_obj_dimensions(obj); isvector(old_data) and pos == fast_subscrv(1, old_data) and d == fast_subscrv(2, old_data) and dims == fast_subscrv(3, old_data) enddefine; define /* lconstant */ get_obj_edge_data(obj) -> edge_data; lvars pos, testpos = false, obj, edge_data, p1, p2, d, i, vertices, current_pos; if isvector(obj) then obj ->>pos->testpos; ->obj; else pb_obj_position(obj) -> pos endif; pb_obj_position(obj) -> current_pos; pb_obj_edge_data(obj) -> edge_data; pb_obj_direction(obj) -> d; if same_situation(obj, pos, edge_data) then fast_subscrv(4, edge_data) -> edge_data; else if testpos then testpos -> pb_obj_position(obj); endif; /* pretend it's at the new pos */ obj_vertices(obj) -> vertices; if testpos then current_pos -> pb_obj_position(obj) endif; /* restore */ vertices(1) -> p1; {% for i from 2 to length(vertices) do fast_subscrv(i, vertices) -> p2; valof("ncmapdata")(p1, round) -> p1; /* this allows fi pdrs to be used in intersection pdr */ {%p1, p2, get_ray_between(p1, p2) %}; p2 -> p1; endfor %} -> edge_data; if not(testpos) then /* save new data */ {% pos, d, pb_obj_dimensions(obj), edge_data %} -> pb_obj_edge_data(obj); endif; endif; enddefine; /* -- Crashes -------------------------------------- */ define pb_enclosed_within(vertex, obj); lvars obj, params = get_obj_edge_data(obj), vertex, vertex1 = false, vertex2, vertex3, vec, d1, d2, d2, a1, a2, d3, i, dims; lconstant circle_shapes = [circle dalek]; if fast_lmember(pb_obj_shape(obj), circle_shapes) and (pb_obj_dimensions(obj) ->> dims)(1) = dims(2) then return(pb_distance_between(obj, vertex) <= (dims(1) * 0.5)) else for i to length(params) do fast_subscrv(i, params) -> vec; fast_subscrv(1, vec) -> vertex2; fast_subscrv(2, vec) -> vertex3; if vertex1 then pb_direction_towards(vertex2, vertex1) -> d1; pb_direction_towards(vertex2, vertex3) -> d3; pb_direction_towards(vertex2, vertex) -> d2; pb_angle_between(d1, d3) -> a1; pb_angle_between(d1, d2) -> a2; if sign(a1) /== sign(a2) or abs(a1) < abs(a2) then return(false); endif; endif; vertex2 -> vertex1; endfor; return(true); endif; enddefine; define pb_coords_out_of_bugworld(pos) -> result; lvars pos, x, y, t = 0, result = false; if isinteger(pos) do pos -> t; -> pos endif; pos(1) -> x; pos(2) -> y; if pb_obj_shape(pb_map(1)) == "circle" then pb_distance_between(pos, {50 50}) > 50 -> result else x < t or y < t or x > (pb_max_coord-t) or y > (pb_max_coord-t) -> result; endif; enddefine; define pb_object_out_of_bugworld(obj) -> result; lvars obj result = true, edge_data, n, i, vertex, bugworld = pb_map(1); get_obj_edge_data(obj) -> edge_data; length(edge_data) -> n; for i from 1 to n do fast_subscrv(1, fast_subscrv(i, edge_data)) -> vertex; if pb_enclosed_within(vertex, bugworld) do false -> result; return; endif; endfor; enddefine; define /* lconstant */ is_nearby(obj, pos2); lvars pos2, obj, dis = pb_distance_between(obj, pos2), dims = pb_obj_dimensions(obj); dims and dis < dims(1) + dims(2) enddefine; define /* lconstant */ penetrable_obj(obj); lvars obj; not(fast_lmember(pb_obj_innards(obj), pb_impenetrable_substances) or fast_lmember(pb_obj_boundary(obj), pb_impenetrable_substances)) enddefine; define pb_obstruction_at(inquirer, pos); lvars pos, inq_pos, i, j, n = 1, obj, vertex, result = false, inquirer, params, s, check; false -> obstruction_encountered; if isinteger(inquirer) then pb_map(inquirer) -> inquirer endif; if inquirer then get_obj_edge_data(inquirer, pos) -> params; pb_obj_position(inquirer) -> inq_pos; length(params) + 1 -> n; /* arrange to check central position as well as corners */ endif; for i from pb_n_objects by -1 to 1 do if (pb_map(i) ->> obj) and obj /== inquirer and not(penetrable_obj(obj)) and is_nearby(obj, pos) then if not(inquirer) then if pb_enclosed_within(pos, obj) and fast_lmember(pb_obj_innards(obj), pb_impenetrable_substances) then return(pb_obj_number(obj ->> obstruction_encountered)) endif; elseif fast_lmember(pb_obj_boundary(obj), pb_impenetrable_substances) then /* check whether bug is currently inside or outside the obj */ if pb_enclosed_within(inq_pos,obj) do not else identfn endif -> check; /* now see if bug is already inside an impentrable object */ if check==not and pb_obj_innards(obj)=="rock" do return(pb_obj_number(obj)) endif; /* now check if bug is trying to move through an impen. boundary */ for j from 1 to n do if j == n then pos else params(j)(1) endif -> vertex; if check(pb_enclosed_within(vertex, obj)) do return(pb_obj_number(obj ->> obstruction_encountered)); endif; endfor; endif; endif; endfor; return(false); enddefine; define /* lconstant */ pb_is_occupied(pos); lvars pos; pb_obstruction_at(false, pos); enddefine; /* -- Updating objects ----------------------------- */ define pb_legalise_value(obj_i, f, v) -> v; lvars dims, x, y, v, xo, yo, obj = pb_map(obj_i), col, o; if pb_grid_world then /* cellular world - normalise position and dimensions */ if f == "dimensions" then explode(v) -> (x,y); (max(1, (x div pb_grid_world)) * pb_grid_world) -> x; (max(1, (y div pb_grid_world)) * pb_grid_world) -> y; unless obj_i == 1 do x-2 -> x; y-2 -> y; endunless; {%x,y%} -> v; endif; if f == "direction" and pb_grid_world_alignment then (v div pb_grid_world_alignment) * pb_grid_world_alignment -> v; endif; if f == "position" and (pb_obj_dimensions(obj) ->> dims) then explode(dims) -> (xo,yo); xo / 2 -> xo; yo / 2 -> yo; explode(v) -> (x,y); x - xo -> x; y - yo -> y; ((x div pb_grid_world) * pb_grid_world) + xo -> x; ((y div pb_grid_world) * pb_grid_world) + yo -> y; unless obj_i == 1 do x + 1 -> x; y + 1 -> y; endunless; {%x,y%} -> v; endif; /* if f == "display_level" and v > 1 then mishap('Cannot change display level when using display-mapped world', []); endif; */ endif; if pb_display_mapped_world then if f == "colour" or f == "trail_colour" then if (pb_obj_with_colour(v) ->> o) and pb_obj_colour(o) /== v then /* inconsistency - rectify if */ false -> pb_obj_with_colour(v); endif; if illegal_colour(v) or ((pb_obj_with_colour(v) ->> o) and o /== obj) then /* try to substitute a legal alternative */ if f == "trail_colour" then "background" -> v; elseif ispair(pb_available_colours) do destpair(pb_available_colours) -> (v, pb_available_colours); else mishap('Run out of unique colours in display-mapped world', [pb_legalise_value]); endif; endif; endif; endif; enddefine; define pb_set_val(obj, f, v); lvars obj, f, v, pdr, l, xo, yo, dims, x, y; /* Convert assignments if necessary */ if islist(v) and (f =="position" or f=="dimensions") then consvector(destlist(v)) -> v; elseif not(v) then return; endif; pb_legalise_value(pb_obj_number(obj), f, v) -> v; valof(pb_obj_field_map(f)(2)) -> pdr; v -> pdr(obj); if f == "dimensions" and pb_grid_world then pb_set_val(obj, "position", pb_obj_position(obj)); endif; if f == "colour" then obj -> pb_obj_with_colour(v); endif; enddefine; define /* lconstant */ parse_field_spec(spec) -> f -> v; lvars spec f = 'attribute', v = spec, res, illegality_pred; lconstant l = '[ ]'; dlocal pop_pr_quotes = false; l -> res; unless ispair(spec) and listlength(spec) == 2 and (dl(spec) -> (f,v), f) and fast_lmember(f, pb_field_names) and (not(isprocedure(subscrv(1, pb_obj_field_map(f)) ->> illegality_pred)) or (not(illegality_pred(v)) ->> res)) then spec -> it; if isclosure(illegality_pred) then frozval(1, illegality_pred) -> res; endif; mishap('Setting illegal attribute value: '>_# elseif val == "impenetrable_shell" then #_<[[boundary rock][innards air]]>_# elseif val == "penetrable" then #_<[[boundary mist][innards mist]]>_# elseif val == "penetrable_shell" then #_<[[boundary mist][innards air]]>_# elseif val == "rubber" then #_<[[boundary rubber][innards rubber]]>_# elseif val == "rubber_shell" then #_<[[boundary rubber][innards air]]>_# else mishap('Illegal substance value', [^val]); endif; enddefine; define /* lconstant */ update_fields(obj, fields); lvars obj fields, l obj2, f, v, d, name, vals, pred, v1, o; dlocal pop_pr_quotes = false; if islist(fields) then for l in fields do unless ispair(l) do mishap('Illegal spec: '>> f) == "substance" then /* old-style attribute */ convert_substance_value(l(2)) -> l; pb_set_val(obj, dl(l(1))); pb_set_val(obj, dl(l(2))); nextloop; elseif f == "procedure" or f == "dynamics" then "behaviour" -> hd(l); endif; parse_field_spec(l) -> f -> v; unless f == "position" and not(pb_clear_move_to(pb_obj_number(obj), v)) do pb_set_val(obj, f, v); endunless; endfor; endif; enddefine; define pb_update_obj(obj, value); lvars obj value, pdr; lconstant fields = [[0 0]], field = fields(1); dlocal pb_chunk_showdisplay_calls = false, pop_pr_quotes = false; if isinteger(obj) do pb_map(obj) -> obj endif; if isvector(value) or isprocedure(value) do chain(obj, value, pb_attempt) endif; if pb_screen_display and pb_screen_display /== "tty" and (pb_allow_display_updates==true or pb_allow_display_updates == "unshow") do pb_unshow_obj(obj); endif; if value == false then /* object kill */ false -> pb_map(pb_obj_number(obj)); elseif isnumber(value) then /* new direction */ "direction" -> field(1); value mod 360 -> field(2); update_fields(obj, fields); elseif ispair(value) then if isnumber(hd(value)) do update_fields(obj, [[position ^value]]); elseif not(ispair(hd(value))) do update_fields(obj, [^value]); else update_fields(obj, value); endif; else mishap('Illegal update value: '> pb_update_count; false -> pb_chunk_showdisplay_calls; if (pb_allow_display_updates == true or pb_allow_display_updates=="show") do if pb_screen_display and pb_screen_display /== "tty" then pb_show_obj(obj) elseif pb_screen_display == "tty" then nl(1); ppr([% pb_obj_name(obj) % 'updated:' ^value]); endif; endif; if isprocedure(recursive_valof(pb_obj_update_trap(obj)) ->> pdr) then pdr(obj); endif; enddefine; define pb_update_obstructed(obj, value) -> obstruction_encountered; lvars obj value; dlocal obstruction_encountered = false; pb_update_obj(obj, value); enddefine; /* -- Sensors ---------------------- */ include xpt_coretypes; /* FOR XptString TYPESPEC */ define pb_display_image -> image; lvars image, c, w, y, x; lconstant v = {^false ^false}; if (v(1) ->> c) and c == pb_update_count then v(2) -> image; else sd_widget(sd_displays(pb_display_name)) -> w; XptVal w (XtN height :XptDimension) -> y; XptVal w (XtN width :XptDimension) -> x; XpwGetImage(w, 0, 0, x, y, false,false) -> image; fill(pb_update_count, image, v) ->; endif; enddefine; define /* lconstant */ obj_at(x,y) -> obj_i; lvars obj, obj_i = false, bg = pb_background_colour, display = sd_displays(pb_display_name), widget = sd_widget(display), col; unless pb_display_mapped_world do mishap('The obj_at routine only works with a display-mapped world', []); endunless; if x > pb_max_coord or y > pb_max_coord or x < 1 or y < 1 then 1 -> obj_i; return; endif; sd_U2X_coords(x, y, pb_display_name) -> (x,y); /* could make this go faster by pulling out image first */ sd_colour_of_pixel(XpwPixelValue(pb_display_image(), x, y)) -> col; if pb_grid_world and (col == bg or col == pb_grid_line_colour) then /* cell boundary - ignore it */ elseif (pb_obj_with_colour(col) ->> obj) then pb_obj_number(obj) -> obj_i; endif; enddefine; define /* lconstant */ satisfies(obj_i, c, pb_i); lvars obj_i, obj = pb_map(obj_i), pb_i, pb = pb_map(pb_i), pos = pb_obj_position(pb), c, pdrs, x, y; unless ispb_obj(obj) do return(false) endunless; ((isword(c) and (pb_obj_name(obj) == c or pb_obj_type(obj) == c or pb_obj_colour(obj) == c or pb_obj_shape(obj) == c or pb_obj_boundary(obj) == c)) or (isnumber(c) and obj_i /== 1 and (pb_distance_between(obj, pb) <= c)) or ((ispair(c) or isvector(c)) and ((pb_obj_field_map(c(1)) ->> pdrs) and valof(pdrs(2))(obj) = c(2)))) enddefine; define sensor_ray_intersection_trap; -> (,,); enddefine; define /* lconstant */ get_display_mapped_objects_along(dir, pos, constraints, pb_i) -> objects; lvars x y, n, limit = 200, objects = [], bug = pb_map(pb_i), blind_spots = pb_obj_blind_spots(bug), yc, xc, obj_i, obj, c, sensed_data; explode(pos) -> (x,y); (dir + pb_obj_direction(bug)) mod 360 -> dir; sin(dir)-> yc; -cos(dir) -> xc; if ispair(constraints) and isinteger(hd(constraints) ->> n) then n -> limit; endif; repeat limit times x + xc -> x; y + yc -> y; if (obj_at(x,y) ->> obj_i) then nextif(obj_i == pb_i); nextif(ispair(objects) and obj_i == fast_front(objects)); for c in constraints do nextunless(satisfies(obj_i, c, pb_i)); endfor; pb_map(obj_i) -> obj; if obj_i == pb_i or (islist(blind_spots) and (fast_lmember(pb_obj_name(obj), blind_spots) or fast_lmember(pb_obj_type(obj), blind_spots) or fast_lmember(pb_obj_colour(obj), blind_spots) or fast_lmember(pb_obj_boundary(obj), blind_spots))) then else pb_obj_sensed_data(obj) -> sensed_data; {%x,y%} -> sensed_data("intersection"); false -> sensed_data("distance"); conspair(obj_i, objects) -> objects; sensor_ray_intersection_trap(x, y, obj); endif; quitif(obj_i == 1); endif; endrepeat; enddefine; define /* lconstant */ get_ray_based_on_y_intercept(x1,y1,x2,y2) -> ray; lvars x1 y1 x2 y2, slope_direction; dlocal popdprecision = true; if x2 = x1 then false -> ray; return endif; lvars yd = (y2 - y1), xd = (x2 - x1), slope = yd / xd, y_intercept = ((y1 * x2) - (x1 * y2)) / (x2 - x1); sign(xd) -> slope_direction; /* 1 = forwards, -1 = backwards */ {%y_intercept, slope, slope_direction%} -> ray; enddefine; define /* lconstant */ revexplode(p) -> y -> x; lvars p x y; if islist(p) then destlist(p) else destvector(p) endif -> -> x -> y; enddefine; define /* lconstant */ get_ray_between(p1,p2); {% get_ray_based_on_y_intercept(revexplode(p1), revexplode(p2)), get_ray_based_on_y_intercept(explode(p1),explode(p2)) %} enddefine; define /* lconstant */ get_sensor_ray(d, pb); lvars d, pb, pos = pb_obj_position(pb), x1 = pos(1), y1 = pos(2), x2, y2; pb_rotated_coords(x1-1,y1,x1,y1,d) -> (x2, y2); get_ray_between(pos, {^x2 ^y2}); enddefine; define /* lconstant */ intersection_of(ray1, ray2) -> x -> y; lvars x, y = false, y_int1 = ray1(1), x_slope1 = ray1(2), y_int2 = ray2(1), x_slope2 = ray2(2), p; if x_slope1 = x_slope2 then y_int1 = y_int2 ->> x -> y; return endif; (y_int2 - y_int1) / (x_slope1 - x_slope2) -> x; ((y_int2 * x_slope1) - (y_int1 * x_slope2)) / (x_slope1 - x_slope2) -> y; enddefine; /* The slope-sign axis is just `not the intercept axis' */ define /* lconstant */ get_ray_intersection(ray1, ray2) -> (x, y, intercept, slope_sign_axis); lvars x, y = false, r1x = ray1(1), r1y = ray1(2), r2x = ray2(1), r2y = ray2(2), slope_sign_axis = 1, intercept; if r1y and r2y then /* get intersection of two rays based on y intercepts */ intersection_of(r1y,r2y) -> x -> y; 1 -> slope_sign_axis; elseif r1x and r2x then /* get intersection from two rays based on x intercepts */ intersection_of(r1x,r2x) -> x -> y; if y then y, x -> y, ->x; endif; /* reverse coords */ 2 -> slope_sign_axis; /* one ray points due north the other points due west */ elseif r1x and r2y then /* r1 has x-based intercept only (due north), r2 has y-based intercept only (due west) */ r1x(1) -> x; r2y(1) -> y; 2 -> slope_sign_axis; elseif r1y and r2x then /* r1 has y-based intercept only (due west), r2 has y-based intercept only (due north) */ r1y(1) -> y; r2x(1) -> x; 1 -> slope_sign_axis; endif; /* Sadly, can't use integers for intercepts. Rounding can obliterate tiny differences and thus change the sign of the intercept/ray-origin difference. */ if slope_sign_axis == 1 then x else y endif -> intercept; if isnumber(x) then round(x) -> x; endif; if isnumber(y) then round(y) -> y; endif; enddefine; define /* lconstant */ get_intersection_with_edge(edge_ray,p1,p2,ray,ray_origin) -> intersection; lvars x, y, x1,y1,x2,y2, prox, edge_map,p1, p2, ray, edge_ray, p ray_origin, pdr, ray_sign, slope_sign_axis, val, field_vec, new_prox, intercept, slope_sign_axis, intercept_axis, intersection = false; min_&_max(p1(1),p2(1)) -> x1 -> x2; min_&_max(p1(2),p2(2)) -> y1 -> y2; get_ray_intersection(ray, edge_ray) -> (x, y, intercept,slope_sign_axis); if slope_sign_axis == 1 then 2 else 1 endif -> intercept_axis; if y and x fi_>= x1 and x fi_<= x2 and y fi_>= y1 and y fi_<= y2 and sign(intercept - (ray_origin(slope_sign_axis))) = subscrv(3, ray(intercept_axis)) then consvector(x,y,2) -> intersection; endif; enddefine; define /* lconstant */ get_intersections_with_circle(cr,cx,cy,lm,ly) -> intersection; lvars intersection = false, a = lm * lm + 1, b = (2 * ly * lm - 2 * cx - 2 * cy * lm), c = (ly * ly + cx * cx - 2 * cy * ly + cy * cy - cr * cr), det = (b * b - 4 * a * c), x1, y1, y2, x2; if det >= 0 then (-b + sqrt(det)) / (2 * a) -> x1; (-b - sqrt(det)) / (2 * a) -> x2; lm * x1 + ly -> y1; lm * x2 + ly -> y2; {{%x1,y1%}{%x2,y2%}} -> intersection; endif; enddefine; define get_intersection_with_circle(obj,ray,ray_origin) -> intersection; lvars obj, ray, ray_origin, y_based_ray = false, x, y, slope_sign, intersections, intersection = false, slope_sign_axis, n, int_2, int_1, int_1_1, int_2_1; dlocal popdprecision = true; if isinteger(obj) do pb_map(obj) -> obj endif; if ray(1) and ray(2) then /* try to find one with low intercept for accuracy */ if abs(ray(1)(1)) < abs(ray(2)(1)) then ray(1) -> ray else ray(2) ->> ray -> y_based_ray endif; elseif ray(2) then ray(2) ->> ray -> y_based_ray else ray(1) -> ray; endif; if y_based_ray then 1 else 2 endif -> slope_sign_axis; explode(pb_obj_position(obj)) -> (x,y); get_intersections_with_circle( pb_obj_dimensions(obj)(1) / 2, if y_based_ray do x,y else y,x endif, ray(2), /* intercept */ ray(1) /* slope */ ) -> intersections; if intersections then /* filter out ones which are `behind' bug */ ray(3) -> slope_sign; {% if sign(intersections(1)(1) - ray_origin(slope_sign_axis)) == slope_sign then intersections(1); endif; if sign(intersections(2)(1) - ray_origin(slope_sign_axis)) == slope_sign then intersections(2); endif %} -> intersections; /* make sure we have an intersection on the right side of the circle */ if (length(intersections) ->> n) == 2 then if abs(intersections(1)(1) - ray_origin(slope_sign_axis)) < abs(intersections(2)(1) - ray_origin(slope_sign_axis)) then intersections(1) -> intersection; else intersections(2) -> intersection endif; elseif n == 1 then intersections(1) -> intersection; endif; /* return coords if using x-based ray */ if intersection and not(y_based_ray) then explode(intersection) -> (y,x); {^x ^y} -> intersection; endif; endif; enddefine; define /* lconstant */ get_intersection_with(obj_i,ray,ray_origin) -> intersection; lvars ray, obj_i, obj = pb_map(obj_i), ray_origin, prox, edge_data, j, vec, edge_ray, p1, p2, p, dis = 9999, d, intersection = false, shape; if (pb_obj_shape(obj) ->> shape) == "circle" or shape == "dalek" then get_intersection_with_circle(obj_i,ray,ray_origin) -> intersection; else get_obj_edge_data(obj) -> edge_data; for j from 1 to length(edge_data) do fast_subscrv(j, edge_data) -> vec; destvector(vec) -> -> edge_ray -> p1 -> p2; get_intersection_with_edge(edge_ray,p1,p2,ray,ray_origin) -> p; if p and (pb_distance_between(ray_origin, p) ->> d) < dis then p -> intersection; d -> dis; endif; endfor; endif; enddefine; define get_ray(ray_dir, pb) -> ray; lvars ray_dir = round(ray_dir), pb, data, ray_sensor_data = pb_obj_ray_sensor_data(pb), pos = pb_obj_position(pb), dir = pb_obj_direction(pb); if property_size(ray_sensor_data) fi_> 512 /* only 360 possible directions */ then mishap('Runaway expansion of ray_sensor_data property', []); endif; if isvector(ray_sensor_data(ray_dir) ->> data) and data(1) = dir and data(2) = pos then /* ray data still valid */ data(3) -> ray; else /* reconstruct ray */ get_sensor_ray(ray_dir + dir, pb) -> ray; {^dir ^pos ^ray} -> ray_sensor_data(ray_dir); endif; enddefine; /* Object-collector for ray (probe) sensor */ define /* lconstant */ get_objects_along(dir, constraints, pb_i) -> objects; lvars a = 1, dir, obj, pb_i, pb = pb_map(pb_i), ray = get_ray(dir, pb), blind_spots = pb_obj_blind_spots(pb), ray_origin = pb_obj_position(pb), p, intersection , objects = [], sensed_data, constraints, c, i, range_limit = false; if pb_display_mapped_world then get_display_mapped_objects_along(dir, ray_origin, constraints, pb_i) -> objects; return; endif; if blind_spots = [bugworld] then 2 -> a; false -> blind_spots endif; for c in constraints do if isinteger(c) then c -> range_limit; endif; endfor; for i from a to pb_n_objects do pb_map(i) -> obj; /* first check whether obj is obviously invisible */ if obj == false or obj == pb or (islist(blind_spots) and (fast_lmember(pb_obj_name(obj), blind_spots) or fast_lmember(pb_obj_type(obj), blind_spots) or fast_lmember(pb_obj_colour(obj), blind_spots) or fast_lmember(pb_obj_boundary(obj), blind_spots))) then nextloop; endif; for c in constraints do nextunless(isinteger(c) or satisfies(i, c, pb_i))(2) endfor; /* now check its edges for a possible intersection */ if (get_intersection_with(i,ray,ray_origin) ->> intersection) then nextif(range_limit and pb_distance_between(ray_origin, intersection) > range_limit); sensor_ray_intersection_trap(explode(intersection), obj); pb_obj_sensed_data(obj) -> sensed_data; intersection -> sensed_data("intersection"); false -> sensed_data("distance"); conspair(i, objects) -> objects; endif; endfor; enddefine; define pb_get_objects_along(dir, bug) -> objects; lvars bug, dir, dir1 = pb_obj_direction(bug), objects; 0 -> pb_obj_direction(bug); get_objects_along(dir, [], pb_obj_number(bug)) -> objects; dir1 -> pb_obj_direction(bug); enddefine; /* Object-collector for directionally sensitive sensor */ define get_objects_around(dir, constraints, pb_i) -> objects; lvars dis_mass = 0.5, angle_mass, pb_i, pb = pb_map(pb_i), dir, objects = [], i, obj, c, constraints, dis, dir1, angle; if isvector(dir) then dir(2) -> dis_mass; dir(1) -> dir; endif; 1 - dis_mass -> angle_mass; dir + pb_obj_direction(pb) -> dir; for i from 1 to pb_n_objects do nextunless(pb_map(i) ->> obj); for c in constraints do nextunless(satisfies(i, c, pb_i))(2) endfor; conspair(i, objects) -> objects; pb_distance_between(pb, obj) -> dis; pb_direction_towards(pb, obj) -> dir1; abs(pb_angle_between(dir, dir1)/180) -> angle; (dis*dis_mass) + (angle*pb_max_distance*angle_mass) ->> dis -> pb_obj_sensed_data(obj)("distance"); endfor; enddefine; /* Object-collector for a sector sensor */ define /* lconstant */ get_objects_in(lo, hi, constraints, pb_i, map) -> objects; lvars sector lo, hi, constraints, pb_i, pb = pb_map(pb_i), d1 = pb_obj_direction(pb), map, i, submap, n o, obj, c, constraints, objects = [], d2, dirs; /* pb_nodups(get_objects_along(lo,constraints, pb_i) <> get_objects_along(hi, constraints, pb_i)) -> objects; */ for i from 1 to pb_n_objects do nextunless(i /== pb_i and (map(i) ->> dirs)); for c in constraints do nextunless(satisfies(i, c, pb_i))(2) endfor; for d2 in dirs do if d2 >= lo and d2 <= hi and not(fast_lmember(i, objects)) then conspair(i, objects) -> objects; /* lose any previous distance value */ false -> pb_obj_sensed_data(pb_map(i))("distance"); endif; endfor; endfor; enddefine; define /* lconstant */ instantiate_object_map(bug, map); lvars bug map, i, obj, d, submap, d1, d2, k, dirs, d3, corners, j, d = pb_obj_direction(bug); clearproperty(map); for i from 1 to pb_n_objects do pb_map(i) -> obj; nextif(obj == false or obj == bug); {%, pb_obj_position(obj), obj_corners(obj) %} -> corners; [% for j from 1 to length(corners) do round(pb_direction_towards(bug, corners(j)) - d) endfor %] -> map(i); endfor; enddefine; /* Filters of various sorts */ define /* lconstant */ get_sensed_distance(obj, sensed_data) -> d; lvars obj, sensed_data, d, pos; unless (sensed_data("distance") ->> d) do unless (sensed_data("intersection") ->> pos) do pb_obj_position(obj) -> pos; endunless; pb_distance_between(pb_obj_position(current_bug), pos) -> d; d -> sensed_data("distance"); endunless; enddefine; define /* lconstant */ get_nearest(objects) -> nearest; lvars nearest = false, sensed_data, dis = 9999, d, obj; /* cannot drop out if only one object - must set distance value of obj */ for obj in objects do if isinteger(obj) then pb_map(obj) -> obj endif; nextunless(pb_isobj(obj)); get_sensed_distance(obj, pb_obj_sensed_data(obj)) -> d; if d < dis then d -> dis; obj -> nearest; endif; endfor; if nearest do [^(pb_obj_number(nearest))] else [] endif -> nearest; enddefine; define /* lconstant */ get_prox(objects); lvars obj objects; define /* lconstant */ prox_of(obj); lvars d; if isinteger(obj) and not(pb_map(obj) ->> obj) do return(0) endif; get_sensed_distance(obj, pb_obj_sensed_data(obj)) -> d; if d then 1 - (d/pb_max_distance) else 0 endif; enddefine; maplist(objects, prox_of); enddefine; define /* lconstant */ get_prox1; get_nearest(); get_prox(); enddefine; define /* lconstant */ get_dir(objects); lvars obj objects, bug = pb_current_bug; define /* lconstant */ dir_of(obj); lvars d; if isinteger(obj) then pb_map(obj) -> obj endif; pb_direction_towards(bug, obj) / 360; enddefine; maplist(objects, dir_of); enddefine; define /* lconstant */ get_dir1; get_nearest(); get_dir() enddefine; define /* lconstant */ get_vals(objects, field); lvars obj objects field; maplist(objects, pb_map <> field); enddefine; define /* lconstant */ get_colour(objects); lvars objects obj; maplist(objects, procedure(obj); pb_obj_colour(pb_map(obj)) endprocedure) enddefine; define /* lconstant */ get_col(objects); lvars objects obj; maplist(objects, procedure(obj); pb_colour_code(pb_obj_colour(pb_map(obj))) endprocedure) enddefine; define /* lconstant */ get_col1; get_nearest(); get_col(); enddefine; define /* lconstant */ get_colour1; get_nearest(); get_colour(); enddefine; define /* lconstant */ get_num(objects); lvars objects, obj; maplist(objects, procedure(obj); obj / pb_n_objects endprocedure) enddefine; define /* lconstant */ get_num1; get_nearest(); get_num() enddefine; define /* lconstant */ get_split_vals(vals); lvars vals, val; [% for val in vals do (val * 2) - 1.5 endfor %] enddefine; define /* lconstant */ get_inv_vals(vals); lvars vals, val; [% for val in vals do -val endfor %] enddefine; define /* lconstant */ get_inputs(objects); lvars obj objects; [% for obj in objects do pb_obj_sensor_inputs_data(obj)(2) endfor %] enddefine; define /* lconstant */ get_inputs1; get_nearest(); get_inputs() enddefine; define /* lconstant */ sensor_converter(name) -> pdr; lvars name, pdr = false; dlocal pop_pr_quotes = false; if ispair(name) then /* special filter spec */ return endif; unless (isprocedure(name) and name ->> pdr) or ((name == "nearest" or name == "first" or name == 1) and get_nearest ->> pdr) or (name == "prox" and get_prox ->> pdr) or (name == "col" and get_col ->> pdr) or (name == "colour" and get_colour ->> pdr) or (name == "num" and get_num ->> pdr) or (name == "dir" and get_dir ->> pdr) or (name == "prox1" and get_prox1 ->> pdr) or (name == "col1" and get_col1 ->> pdr) or (name == "colour1" and get_colour1 ->> pdr) or (name == "num1" and get_num1 ->> pdr) or (name == "dir1" and get_dir1 ->> pdr) or (name == "split" and get_split_vals ->> pdr) or (name == "inv" and get_inv_vals ->> pdr) or (name == "input" and get_inputs ->> pdr) or ((name == "inputs1" or name == "input1") and get_inputs1 ->> pdr) or (not(isnumber(name)) and isdefined(name) and isprocedure(valof(name) ->> pdr)) or (isdefined(consword('pb_obj_'>> name) and (get_vals(%recursive_valof(name)%) ->> pdr)) do false -> pdr; endunless; enddefine; define /* lconstant */ parse_sensor(sensor) -> (field, filters, converters); lvars field = false, filters = [], converters = [nearest prox], x, y; /* check for prox sensor in semi-shorthand and put in full shorthand*/ if ispair(sensor) and fast_back(sensor) == [] and not(ispair(fast_front(sensor))) then /* single item in a list */ hd(sensor) -> sensor; endif; if isprocedure(sensor) or isinteger(sensor) then /* pdr or ordinary prox sensor in full shorthand */ sensor -> field; elseif ispair(sensor) then /* normal list-format sensor-spec */ if isinteger(hd(sensor) ->> x) or isvector(x) then /* field spec */ destpair(sensor) -> sensor -> field; endif; /* check for an old-style sensor and convert */ if (x == "prox" or x == "col") and ispair(tl(sensor)) and isinteger(hd(tl(sensor)) ->> y) then y -> field; [1 ^x] -> converters; return; endif; /* peel off the filters, if any */ until sensor == [] or sensor_converter(hd(sensor) ->> x) do conspair(x, filters) -> filters; fast_back(sensor) -> sensor; enduntil; if sensor /== [] then /* converters given */ sensor -> converters endif; else mishap('Bad sensor specification', [^sensor]) endif; enddefine; define /* lconstant */ get_sensor_rays(pb) -> rays; lvars sensors = pb_obj_sensors(pb), d = pb_obj_direction(pb), pos = pb_obj_position(pb), x1 = pos(1), y1 = pos(2), x2 y2, rays = [], s, d1, i; lconstant vec = {0}; for s in sensors do parse_sensor(s) -> (field,,); if isnumber(field) then field -> vec(1); vec -> field; endif; for i from 1 to length(field) do field(i) -> d1; pb_rotated_coords(x1-pb_max_coord,y1,x1,y1,d+d1) -> (x2, y2); conspair({^x1 ^y1 ^x2 ^y2}, rays) -> rays; endfor; endfor; {% explode(rays) %} -> rays; enddefine; define pb_get_sensor_inputs(bug) -> inputs; lvars bug, pb_i = pb_obj_number(bug), inputs, pos = pb_obj_position(bug), sensors = pb_obj_sensors(bug), field, converters, i = 0, objects, dir = pb_obj_direction(bug), d, p, field, sensor, obj_map = false, data, m = 0, filters, pdr, n, v, converter; lconstant object_map = newmap([]), objects_for = newmap([]); dlocal current_bug; dlocal x y; bug -> current_bug; if (pb_obj_sensor_inputs_data(bug) ->> v)(1) == pb_update_count and pb_use_stored_sensor_inputs then v(2) -> inputs; return; endif; for i from 1 to pb_n_objects do if pb_map(i) then clearproperty(pb_obj_sensed_data(pb_map(i))); endif; endfor; clearproperty(objects_for); unless islist(sensors) do {} -> inputs; return endunless; if isvector(sensors) then [% explode(sensors) %] ->> sensors -> pb_obj_sensors(bug) endif; 0 -> i; {% for sensor in sensors do i fi_+ 1 -> i; parse_sensor(sensor) -> (field, filters, converters); if isvector(field) do length(field) else 0 endif -> n; if isprocedure(field) then /* custom sensor procedure */ field(bug); nextloop; /* assume it does its own post-processing */ elseif (objects_for(sensor) ->> objects) then /* nothing */ elseif isinteger(field) then /* ordinary ray sensor */ get_objects_along(field, filters, pb_i) -> objects; elseif (n == 1 and (isinteger(field(1) ->> x))) or (n == 2 and (isdecimal((field ->> x)(2)) or isratio(x(2)))) then /* directionally-tuned sensor */ get_objects_around(x, filters, pb_i) -> objects; elseif (n == 2 and (field(1) -> x, isinteger(field(2) ->> y))) or (n fi_< 2 and (-360 -> x, 360 ->> y)) then /* non-directional or sector sensor */ unless obj_map do instantiate_object_map(bug, object_map->>obj_map) endunless; get_objects_in(x, y, filters, pb_i, obj_map) -> objects; else mishap('Badly formed sensor', [^sensor]); endif; objects -> objects_for(sensor); /* now apply the sensor converters to the objects */ for converter in converters do sensor_converter(converter) -> pdr; pdr(objects) -> objects; endfor; if objects == [] then 0 else dl(objects) endif; endfor; /* include inputs from misc environment variables for i to length(misc_env_vars) do misc_env_vars(i) -> field; if islist(field) then m fi_+ 1 -> m; field(1); field(2) - 1 ->> n -> field(2); if n <=0 then 0 -> misc_env_vars(i); endif; else field; endif; endfor; if m == 0 then [] -> misc_env_vars endif; */ %} -> inputs; if pb_sensor_noise /== 0 then add_noise(inputs, pb_sensor_noise) -> inputs; endif; pb_inputs_filter(inputs) -> inputs; fill(pb_update_count, inputs, pb_obj_sensor_inputs_data(bug)) ->; enddefine; define pb_get_new_sensor_inputs; dlocal pb_use_stored_sensor_inputs = false; pb_get_sensor_inputs(); enddefine; define pb_make_sensors(template, n, arc) -> spec; lvars template, n, arc, field, constraints, prog, d2, d1, sensor; unless ispair(hd(template)) do [^template] -> template endunless; hd(hd(template)) -> d2; if isvector(d2) then d2(1) -> d2 endif; [% repeat n times d2 -> d1; d2 - arc -> d2; for sensor in template do copylist(sensor) -> sensor; hd(sensor) -> field; if isvector(field) then copy(field) -> field; d1 -> field(1); if length(field) > 1 do d2 -> field(2); endif; else d1 -> field; endif; field -> hd(sensor); sensor; endfor; endrepeat %] -> spec; enddefine; define pb_normal_sensor_spec(n, arc, col) -> spec; pb_make_sensors([10 prox %if col>0 then "col" endif%], n, arc); enddefine; /* -- Trails --------------------------------------- */ define update_trail(bug); lvars bug, trail, i; if pb_is_bug(bug) then pb_obj_trail_data(bug) -> trail; pb_cycle_number mod property_size(trail) -> i; if not(trail(i)) then {0 0} -> trail(i) endif; fill(pb_obj_direction(bug), pb_obj_position(bug), trail(i)) ->; endif; enddefine; define return_to_trail_position(bug); lvars bug, trail, i, v; if pb_is_bug(bug) then pb_obj_trail_data(bug) -> trail; pb_cycle_number-1 -> pb_cycle_number; pb_cycle_number mod property_size(trail) -> i; if trail(i) ->> v then pb_update_obj(bug, [[direction ^(v(1))][position ^(v(2))]]); endif; endif; enddefine; /* -- Display routines --------------------------- */ define pb_showdisplay(arg); lvars arg; dlocal pb_showdisplay_args; lconstant l = {[]}; if isvector(arg) then arg -> pb_showdisplay_args; -> arg endif; if pb_chunk_showdisplay_calls then /* interacts badly with pb_clip optimising routine */ arg <> l(1) -> l(1); else if l(1) /== [] do l(1) <> arg -> arg; [] -> l(1) endif; if (pb_screen_display and pb_screen_display /== "tty") then valof("showdisplay")(arg, explode(pb_showdisplay_args)) endif; endif; enddefine; vars pb_last_sd_commands; define pb_display_obj(commands); lvars commands arg = false; dlocal sd_allow_line_styles = "mono"; if isword(commands) do commands -> arg; -> commands endif; if islist(pb_clip) then conspair(commands, pb_clip) -> pb_clip; endif; commands -> pb_last_sd_commands; pb_showdisplay(commands, if arg do {^arg} endif); enddefine; define pb_show_caption; dlocal pop_pr_quotes = false; lvars str = pb_caption >< nullstring, x = pb_max_coord+2, display, widget, name; dlocal sd_incremental = true, pop_pr_places = 3; if pb_allow_display_updates then if pb_caption_position == "below" then pb_showdisplay([{space 0 ^(pb_max_coord+5) ^(pb_max_coord+20) ^(pb_max_coord+16)}]); pb_showdisplay([{string %0, pb_max_coord+pb_unit_length% ^str 10} ]); if (sd_displays(pb_display_name) ->> display) and (sd_widget(display) ->> widget) then pb_display_name -> XptVal (widget.XptShellOfObject)(XtN title :XptString); endif; elseif pb_caption_position == "side" then pb_showdisplay([{space ^pb_max_coord 0 ^(pb_max_coord+100) 40}]); pb_showdisplay([{string ^x 10 ^(pb_simulation><'') 14} ]); pb_showdisplay([{string ^x 20 'by' 14} ]); pb_showdisplay([{string ^x 30 ^(pb_topbug_controller><'') 14} ]); elseif pb_caption_position == "title_bar" and (sd_displays(pb_display_name) ->> display) and (sd_widget(display) ->> widget) then ('POPBUGS: ' >< str) ->> name -> XptVal (widget.XptShellOfObject)(XtN title :XptString); endif; endif; enddefine; define pb_show_annotation2(str); lvars str; dlocal sd_incremental = true; if pb_allow_display_updates then pb_showdisplay([{space %0, pb_max_coord+pb_unit_length, pb_max_coord+pb_unit_length, pb_max_coord+(pb_unit_length*2)%} ]); pb_showdisplay([{string %0, pb_max_coord+pb_unit_length*2% ^str 10} ]); endif enddefine; define /* lconstant */ init_display; dlocal sd_comms = [], sd_incremental = false; lconstant win1 = [%-5, -5, pb_max_coord+(pb_unit_length*2), pb_max_coord+(pb_unit_length*2)%], win2 = [0 0 ^pb_max_coord ^pb_max_coord]; pb_display_obj([ {box ^^(if pb_caption_position /== "title_bar" do win1 else win2 endif) white}]); true -> sd_incremental; if pb_simulation /= nullstring then pb_show_caption() endif; enddefine; define pb_show_message(strings); dlocal pop_pr_quotes = false; lvars y = 0, size = pb_message_font_size, colour = "black", i = 0, n, len = 0, str, pause = false; dlocal sd_incremental = false, sd_hard_frame = false; if isword(strings) then strings -> colour; -> strings endif; if isinteger(strings) or strings == false then strings -> size; -> strings; endif; if isboolean(strings) do strings -> pause; -> strings; endif; length(strings) -> n; pb_showdisplay([ % {string 0 0 ^nullstring}; for i to n do y + 1 -> y; quitif(i > n); strings(i) -> str; if size then {string 1 ^y ^(str >< nullstring) ^size ^colour} else {stringin 1 ^y 100 ^(y+0.5)) ^(str >< nullstring) ^colour}; endif; endfor; {string 20 ^(y+1)^nullstring} % ]); if pause then syssleep(300) endif; false -> world_displayed; enddefine; define pb_show_logo; lvars i = 0, y, m, cols = tl(pb_colours), col; (pb_max_coord-(pb_max_coord/5))/4 -> m; pb_showdisplay([ % {box -10 -8 100 110 white}; /* for y from 2 by 3 to pb_max_coord-(pb_max_coord/5) do {string -5 ^y 'LIB POPBUGS' ^pb_message_font_size blue ^(((((i+1->>i)/m)*0.7)-1)*1.0)}; endfor; */ /* for y from 2 by 0.6 to pb_max_coord-(pb_max_coord/5) do quitif(cols == []); {string -5 ^y 'LIB POPBUGS' ^pb_message_font_size %destpair(cols) -> cols%}; endfor; */ 0.1 -> y; repeat 6 times destpair(cols) -> (col,cols); repeat 6 times y + 2.25 -> y; {string -5 ^y 'LIB POPBUGS' ^pb_message_font_size ^col}; endrepeat; endrepeat; {string -5 ^(pb_max_coord-10) 'LIB POPBUGS' ^pb_message_font_size navy}; {string -5 ^(pb_max_coord-3) 'Chris Thornton, 1994' 10 navy}; {string 54 10 'VERSION' NavyBlue '*-i-*-18-*'}; {arc 70 17 80 27 100 240 red 10 []}; {arc 70 27 80 37 250 -240 red 10 []}; /* FOR VERSION 4 {line 70 30 80 15 red 4}; {line 80 15 80 40 red 4}; {line 70 30 85 30 red 4}; {string ^(pb_max_coord/1.6) 50 'SEE HELP' 18 NavyBlue}; {string ^(pb_max_coord/1.6) 54 'FILE FOR' 18 NavyBlue}; {string ^(pb_max_coord/1.6) 70 'CHANGES' 18 NavyBlue}; */ {string 54 50 'New features -' NavyBlue '*-i-*-15-*'}; {string 54 57 'programmable' NavyBlue '*-i-*-15-*'}; {string 54 64 'sensors, running' NavyBlue '*-i-*-15-*'}; {string 54 71 'drag-and-drop,' NavyBlue '*-i-*-15-*'}; {string 54 78 'backgrounding...' NavyBlue '*-i-*-15-*'}; {string 54 88 'See HELP file' NavyBlue '*-i-*-15-*'}; {string 54 95 'for details.' NavyBlue '*-i-*-15-*'}; %]); [] -> sd_comms; false -> world_displayed; enddefine; /* -- Drawing routines ----------------------------- */ define /* lconstant */ get_sd_depth(obj); lvars depth = pb_obj_depth(obj); if isinteger(depth) and depth fi_> 1 then -depth else 0 endif; enddefine; define /* lconstant */ draw_arrow_head(pb); lvars pb c = get_obj_colour(pb), x, y, y1, x1, x2, y2, dims = get_obj_dimensions(pb), dim, c1; explode(pb_obj_position(pb)) -> y -> x; /* (dims(1) + dims(2)) * 0.5 -> dim;*/ dims(1) * 0.75 -> dim; pb_rotated_coords(x-(dims(1)/2),y,x,y,pb) -> (x1, y1); pb_rotated_coords(x-(dim*1.33),y,x,y,pb) -> (x2, y2); {arrow ^x1 ^y1 ^x2 ^y2 ^pb_linesize ^(get_sd_depth(pb)) ^c} :: sd_comms -> sd_comms; enddefine; define /* lconstant */ draw_SR_pair(input, output); lvars input output; dlocal pop_pr_places = 2, pop_pr_quotes = false; [{space 0 ^(pb_max_coord+11) ^(pb_max_coord+20) ^(pb_max_coord+16)} {string 0 ^(pb_max_coord+15) ^(input >< ' --> ' >< output) 0 ^sd_pen_colour } ] <> sd_comms -> sd_comms; enddefine; define /* lconstant */ draw_sensor_intercepts(bug); lvars bug, col = get_obj_colour(bug); dlocal pop_pr_quotes = false, pb_use_stored_sensor_inputs = false; procedure(x,y,obj); lvars x,y,i = pb_obj_number(obj) >< nullstring; if not(pb_show_intercept_numbers) then 'X' -> i endif; conspair({string ^x ^y ^i 0 ^col}, sd_comms) -> sd_comms; endprocedure -> sensor_ray_intersection_trap; pb_get_sensor_inputs(bug) ->; enddefine; define /* lconstant */ draw_sensor_field(pb); lvars pb, rays = get_sensor_rays(pb), ray, i, c = get_obj_colour(pb), c1; for i to length(rays) do {line %explode(rays(i)),'-',0,c%} :: sd_comms -> sd_comms; endfor; enddefine; /* COULD BE USEFUL define /* lconstant */ draw_shading(obj); lvars y, x, a, z, col = get_obj_colour(obj); define /* lconstant */ xshift; repeat 3 times if (get_obj_at(x,y) == obj) do x + 1 -> x endif; endrepeat; enddefine; for y from 1 by 3 to pb_max_coord do false ->> a -> z; for x from 1 to pb_max_coord do if get_obj_at(x,y) == obj then if a do {^x ^y} -> z; if pb_distance_between(a,z) > 2 then {line ^^a ^^z 0 ^col} :: sd_comms -> sd_comms; endif; false -> a; xshift(); else xshift(); {^x ^y} -> a; endif; endif; endfor; endfor; enddefine; */ define draw_circle_of(x,y,xr,yr,c,f,obj); lvars x,y,xr,yr,c,f, obj; {circle %x-xr,y-yr,x+xr,y+yr% ^f ^pb_linesize ^(get_sd_depth(obj)) ^c} :: sd_comms -> sd_comms; enddefine; define /* lconstant */ draw_circle(obj); lvars obj, pos = pb_obj_position(obj), dims = pb_obj_dimensions(obj), c, f; get_col_&_fill(obj) -> (c,f); if isvector(c) and length(c) >= 3 then c(1) -> c endif; if pb_obj_direction(obj) == 0 then draw_circle_of(explode(pos), dims(1)/2, dims(2)/2, c, f, obj); else draw_circle_of(explode(pos), dup(dims(1)/2), c, f, obj); endif; enddefine; define /* lconstant */ draw_dalek(obj); lvars pos = pb_obj_position(obj), dims = pb_obj_dimensions(obj), c, f; dlocal compulsory_colour; get_col_&_fill(obj) -> (c,f); draw_circle_of(explode(pos), dup(dims(1)/2),c,f, obj); draw_arrow_head(obj); enddefine; define draw_tracks(bug); lvars bug, c = get_obj_colour(bug), w = pb_obj_tracklength(bug), dims = pb_obj_dimensions(bug), dims_copy = {% explode(dims) %}, fr, fl, bl, br, x1, y1, x2, y2; if isdecimal(w) then dims(1) * w -> dims(1) endif; get_tracklength(bug) -> dims(2); obj_corners(bug) -> (fr, fl, bl, br, fr); conspair({line %fl(1),fl(2),bl(1),bl(2),3,0,c%}, sd_comms) -> sd_comms; conspair({line %br(1),br(2),fr(1),fr(2),3,0,c%}, sd_comms) -> sd_comms; dims(1) * 0.5 -> dims(1); pb_frontright(bug) -> (x1,y1); pb_frontleft(bug) -> (x2,y2); conspair({line %x1,y1,x2,y2,3,0,c%}, sd_comms) -> sd_comms; pb_backright(bug) -> (x1,y1); pb_backleft(bug) -> (x2,y2); conspair({line %x1,y1,x2,y2,3,0,c%}, sd_comms) -> sd_comms; dims_copy -> pb_obj_dimensions(bug); enddefine; define /* lconstant */ draw_ant(obj); lvars blob, c, f, obj, dims = pb_obj_dimensions(obj), pos = pb_obj_position(obj), x = pos(1), y = pos(2), r = (dims(1)/2), xr, yr, xl, yl; get_col_&_fill(obj) -> (c, f); pb_rotated_coords(x-(r/1.5),y,x,y,obj) -> (xl, yl); pb_rotated_coords(x+(r/1.25),y,x,y,obj) -> (xr, yr); draw_circle_of(xl, yl, dup(r*0.6), c, f,obj); draw_circle_of(xr, yr, dup(r*0.9), c, f,obj); enddefine; define /* lconstant */ draw_line(obj); lvars f, c obj, y1, x1, x2, y2, line_size; get_col_&_fill(obj) -> (c, f); pb_frontmid(obj) -> (x1, y1); pb_backmid(obj) -> (x2, y2); round(pb_obj_dimensions(obj)(2) * 2) -> line_size; {line ^x1 ^y1 ^x2 ^y2 ^f ^line_size 0 ^c} :: sd_comms -> sd_comms; enddefine; define /* lconstant */ draw_box(obj); lvars obj, c, f, d = pb_obj_direction(obj), dims = pb_obj_dimensions(obj), corners, p1, p2, fr, fl, bl, br; get_col_&_fill(obj) -> (c, f); if dims(2) <=2 then draw_line(obj) elseif f == [] then /* unfilled */ obj_corners(obj) -> (fr, fl, bl, br, fr); conspair({line %fr(1),fr(2),fl(1),fl(2),pb_linesize,get_sd_depth(obj),c%}, sd_comms) -> sd_comms; conspair({line %fl(1),fl(2),bl(1),bl(2),pb_linesize,get_sd_depth(obj),c%}, sd_comms) -> sd_comms; conspair({line %bl(1),bl(2),br(1),br(2),pb_linesize,get_sd_depth(obj),c%}, sd_comms) -> sd_comms; conspair({line %br(1),br(2),fr(1),fr(2),pb_linesize,get_sd_depth(obj),c%}, sd_comms) -> sd_comms; else obj_extreme_points(obj) -> (fr,fl,bl,br,fr); conspair({box %explode(fr),explode(bl), if d /= 0 then (d/1.0 mod 360) endif,f,0,c%}, sd_comms) -> sd_comms; endif; enddefine; define /* lconstant */ draw_outline(outline, obj); lvars i, obj, outline, p1 = outline(1), c, f, p2; get_col_&_fill(obj) -> (c, f); for i from 2 to length(outline) do outline(i) -> p2; conspair({line %p1(1),p1(2),p2(1),p2(2),pb_linesize,get_sd_depth(obj),c%}, sd_comms) -> sd_comms; p2 -> p1; endfor; enddefine; define /* lconstant */ draw_tank(obj); draw_box(obj); draw_arrow_head(obj); enddefine; define /* lconstant */ draw_triangle(obj); lvars s = pb_linesize, pos = pb_obj_position(obj),c, f, x = pos(1), y = pos(2), x1, y1, x2, y2; get_col_&_fill(obj) -> (c, f); pb_backright(obj) -> (x1, y1); pb_backleft(obj) -> (x2, y2); pb_rotated_coords(x - (pb_obj_dimensions(obj)(1)/1.5),y,x,y,obj) -> (x, y); conspair({line ^x ^y ^x1 ^y1 ^s 0 ^c}, conspair({line ^x ^y ^x2 ^y2 ^s 0 ^c}, conspair({line ^x1 ^y1 ^x2 ^y2 ^s 0 ^c}, sd_comms))) -> sd_comms; enddefine; define draw_label(obj, label); lvars obj, o = 3, label, fr, fl, bl, br, c, dims = pb_obj_dimensions(obj); get_obj_trail_colour(obj) -> c; if isstring(label) and datalength(label) > 0 and dims(1) > 2 and dims(2) > 2 then dims(1) - o -> dims(1); dims(2) - o -> dims(2); obj_corners(obj) -> (fr, fl, bl, br, fr); conspair({stringin %fr(1), fr(2), bl(1), bl(2), label, 0, c%}, sd_comms) -> sd_comms; dims(1) + o -> dims(1); dims(2) + o -> dims(2); endif; enddefine; define /* lconstant */ show_shape(obj, draw_pdr); lvars d, obj, l = get_obj_display_level(obj), label = pb_obj_label(obj); dlocal sd_comms = [], pb_allow_display_updates = false; if label then draw_label(obj, label) endif; draw_pdr(obj); if pb_is_bug(obj) then /* add in detail according to l */ if l > 1 and l /== 4 and not(pb_display_mapped_world) do draw_sensor_field(obj); endif; if l > 2 and l /== 4 and not(pb_display_mapped_world) then draw_sensor_intercepts(obj); endif; if l >= 4 then draw_tracks(obj) endif; endif; sd_comms -> pb_obj_display_data(obj); if l > 2 and l /== 4 then draw_SR_pair(pb_obj_sensor_inputs_data(obj)(2), pb_obj_action_data(obj)); endif; pb_display_obj(sd_comms); enddefine; define pb_show_obj(obj); lvars obj, shape = get_obj_shape(obj), col = pb_obj_colour(obj), dims = pb_obj_dimensions(obj), pdr, outline, edge_col, mate; dlocal pop_pr_quotes = false, sd_incremental = true, pb_linesize, current_obj = obj; if length(dims) fi_> 2 then dims(3) -> pb_linesize endif; isvector(col) and length(col) >=3 -> edge_col; unless pb_allow_display_updates = false or col == "transparent" do if shape == "box" then show_shape(obj, draw_box); elseif shape == "circle" then show_shape(obj, draw_circle); elseif shape == "ant" then show_shape(obj, draw_ant); elseif shape == "triangle" then show_shape(obj, draw_triangle); elseif shape == "dalek" then if edge_col do show_shape(obj, draw_circle) else show_shape(obj, draw_dalek); endif; elseif shape == "tank" then show_shape(obj, draw_tank); elseif (pb_special_shapes(shape) ->> outline) then obj_outline_points(obj, outline) -> outline; show_shape(outline, obj, draw_outline); else mishap('Unknown shape: '> (pb_obj_colour(obj), pb_obj_innards(obj)); pb_show_obj(obj); (col1, innards) -> (pb_obj_colour(obj), pb_obj_innards(obj)); enddefine; define pb_show_obj_in(colour, obj); lvars obj s1 = pb_obj_shape(obj), s2 = false; dlocal compulsory_colour = colour; if isword(obj) then obj -> s2; colour -> obj; -> colour endif; if not(colour) then return endif; pb_show_obj(obj); enddefine; define /* lconstant */ show_obj_in_as(s); lvars s; dlocal compulsory_shape; s -> compulsory_shape; pb_show_obj_in(); enddefine; define pb_unshow_obj(obj); lvars obj, display_data = pb_obj_display_data(obj), col1 = get_obj_colour(obj), col2, com, n; dlocal current_obj = obj, pb_show_obj_trap = pb_unshow_obj_trap, pb_allow_display_updates = false, sd_incremental = true; get_obj_trail_colour(obj) -> col2; if col2 == "transparent" then pb_background_colour-> col2 endif; if col2 == col1 or not(ispair(display_data)) do return endif; /* if pb_clip do remove_clip_frames(display_data) -> endif;*/ if pb_clip then maplist(display_data, copy) -> display_data; endif; for com in display_data do /* update col and depth params */ datalength(com) -> n; col2 -> fast_subscrv(n, com); fast_subscrv(n-1,com) - 1 -> fast_subscrv(n-1,com); /* increment depth */ endfor; pb_display_obj(display_data); false -> pb_obj_display_data(obj); enddefine; define pb_show_cell_boundaries; lvars x = 0, y = 0, col = pb_grid_line_colour, size = pb_grid_world; dlocal sd_incremental = true, sd_comms = []; unless isinteger(size) do 10 -> size endunless; for x from 0 by size to pb_max_coord do conspair({line ^x 0 ^x ^pb_max_coord ^col}, sd_comms) -> sd_comms; endfor; for y from 0 by size to pb_max_coord do conspair({line 0 ^y ^pb_max_coord ^y ^col}, sd_comms) -> sd_comms; endfor; pb_display_obj(sd_comms); enddefine; define pb_show_all_objects; lvars i, obj, t, depth, new_depths = [], d; /* dlocal sd_incremental = true;*/ lconstant depths = [_ 0]; unless isinteger(pb_n_objects) do return endunless; for depth in tl(depths) do for i from 1 to pb_n_objects do if (pb_map(i) ->> obj) then pb_obj_depth(obj) -> d; if d and not(fast_lmember(d, depths)) then conspair(d, new_depths) -> new_depths; endif; if d==depth then pb_show_obj(pb_map(i)); endif; endif endfor; endfor; if new_depths /== [] do rev(sort(0 :: new_depths)) -> tl(depths); pb_show_all_objects(); endif; if pb_grid_world then pb_show_cell_boundaries() endif; enddefine; define pb_refresh; init_display(); pb_show_all_objects(); true -> world_displayed; enddefine; define pb_save_display(format, file); dlocal pb_showdisplay_args = [^format ^file]; pb_refresh(); enddefine; define pb_flash_obj(obj); lvars c, pdr, obj, list; lconstant cols = pb_colours; if get_obj_display_level(obj) > 1 then allbutlast(length(cols)-3,cols) else cols endif -> list; procedure; applist(list, procedure(c); pb_show_obj_in(c, obj) endprocedure); endprocedure -> pdr; pdr(); pb_show_obj_in("white", obj); /* in case it's an edge-only colour */ pb_show_obj(obj); enddefine; define pb_show(com); dlocal sd_incremental = true; pb_showdisplay([^com]); enddefine; define pb_spin_bug(bug); lvars bug; returnunless(pb_is_bug(bug)); repeat 10 times pb_update_obj(bug, pb_obj_direction(bug)+36) endrepeat; enddefine; /* -- New objects ------------------------------- */ define /* lconstant */ fill_in_defaults(defaults, obj); dlocal field val; lvars defaults, pdr; foreach [?field ?val] in defaults do valof(pb_obj_field_map(field)(2)) -> pdr; if not(pdr(obj)) then pb_set_val(obj, field, val); endif; endforeach; enddefine; /* after v15.01 we seem to be going back to gensym... */ vars /* lvars */ pb_gensym, pb_cleargensymproperty, gen_suffixed_word_prop; if false and sys_autoload("gen_suffixed_word") then valof("gen_suffixed_word") -> pb_gensym; clearproperty(%valof("gen_suffixed_word_prop")%) -> pb_cleargensymproperty; else valof("gensym") -> pb_gensym; valof("cleargensymproperty") -> pb_cleargensymproperty; endif; define /* lconstant */ fill_in_fields(obj) -> obj; lvars x, y, obj, b = pb_obj_behaviour(obj), type = pb_obj_type(obj), col, dir = pb_obj_direction(obj), pos = pb_obj_position(obj), dims = pb_obj_dimensions(obj), shape = pb_obj_shape(obj), x1, y1, x2, y2, x, name, data, shape_name; if not(type) then if pb_is_obstacle(obj) then "obstacle" else "bug" endif -> type; pb_set_val(obj, "type", type); endif; unless member(type, pb_types) do pb_types <> [^type] -> pb_types endunless; /* name default */ unless pb_obj_name(obj) do pb_gensym(type) -> pb_obj_name(obj) endunless; /* direction */ unless isnumber(dir) do if pb_is_bug(obj) then random(360) else 0 endif -> pb_obj_direction(obj); endunless; /* dimensions */ unless isvector(dims) or islist(dims) do if pb_is_bug(obj) then {6 4} else {%random(15)+5, random(15)+5%} endif ->> dims -> pb_obj_dimensions(obj) endunless; if islist(dims) then consvector(destlist(dims)) -> dims; endif; pb_set_val(obj, "dimensions", dims); /* position */ unless isvector(pos) or islist(pos) do pb_find_empty_pos_inside(round(dims(1) * 2)) ->> pos -> pb_obj_position(obj) endunless; if islist(pos) then consvector(destlist(pos)) -> pos; endif; pb_set_val(obj, "position", pos); /* shape defaults */ if islist(shape) then /* custom shape */ pb_gensym("shape") -> shape_name; shape -> pb_special_shapes(shape_name); pb_basic_shapes <> [^(appproperty(pb_special_shapes, erase))] -> pb_shapes; if obj_cp_sheet then /* update menu */ valof("propsheet_field")(obj_cp_sheet, [shape menuof ^pb_shapes]); endif; shape_name ->> shape -> pb_obj_shape(obj); endif; unless member(shape, pb_shapes) do if pb_is_bug(obj) then "ant" else valof("oneof")([box circle]) endif -> shape; pb_set_val(obj, "shape", shape); endunless; /* substance */ if fast_lmember(pb_obj_innards(obj), pb_impenetrable_substances) then pb_obj_innards(obj) -> pb_obj_boundary(obj); endif; /* colour */ pb_set_val(obj, "colour", pb_obj_colour(obj)); if illegal_colour(pb_obj_trail_colour(obj)) then "background" -> pb_obj_trail_colour(obj); endif; pb_set_val(obj, "trail_colour", pb_obj_trail_colour(obj)); /* label */ if not(pb_obj_label(obj)) do pb_set_val(obj, "label", nullstring); endif; /* bug-specific defaults */ if pb_is_bug(obj) then /* fill in bug defaults */ fill_in_defaults([ [sensors [0]] [sensor_places 3] [trail_colour background] [blind_spots [transparent]] [direction 0] [behaviour [[1][1]]]], obj); /* make SURE transparent is a blind spot */ if not(member("transparent", pb_obj_blind_spots(obj))) then "transparent" :: pb_obj_blind_spots(obj) -> pb_obj_blind_spots(obj); endif; endif; enddefine; define pb_new_obj(fields) -> obj; lvars obj, i = false, col; if ispb_obj(fields) then /* make a copy with same name and number */ conspb_obj(destpb_obj(fields)) -> obj; if not(isinteger(pb_obj_number(obj))) then pb_n_objects + 1 ->> pb_n_objects -> pb_obj_number(obj); endif; obj -> pb_map(pb_obj_number(obj)); max(pb_obj_number(obj), pb_n_objects) -> pb_n_objects; /* just in case */ elseif islist(fields) or isinteger(fields) then /* make a new object */ consdefaultpb_obj() -> obj; if isinteger(fields) and pb_map(fields) then /* copy of existing obj with new number */ copy_major_fields(pb_map(fields), obj); endif; pb_n_objects + 1 ->> pb_n_objects -> pb_obj_number(obj); obj -> pb_map(pb_n_objects); if islist(fields) do update_fields(obj, fields); endif; if pb_is_bug(obj) then pb_n_bugs + 1 -> pb_n_bugs endif; fill_in_fields(obj) -> ; /* plug in derived defaults */ else mishap('Bad argument for pb_new_obj', []); endif; if pb_n_objects > 2 and pb_coords_out_of_bugworld(pb_obj_position(obj)) then vedputmessage('WARNING: New object appears to be outside bugworld'); /* vedscreenbell(); */ endif; enddefine; define pb_non_default_fields(obj) -> fields; lvars obj, isbug = pb_is_bug(obj), att, val, pdr, bug; dlocal pop_pr_quotes = false; lconstant default_obs = pb_new_obj([[behaviour static]]), default_bug = pb_new_obj([[behaviour pb_forwards]]); [% for att in pb_field_names do nextif(att == "number"); valof(consword(pb_obj_record_prefix >< att)) -> pdr; pdr(obj) -> val; nextif(not(val) or issubstring('data',att)); if isbug and pdr(obj) /= pdr(default_bug) or not(isbug) and val /= pdr(default_obs) then [^att ^val]; endif; endfor %] -> fields; enddefine; define pb_get_current_specs; lvars i fields, obj; [% for i from 1 to pb_n_objects do nextunless(pb_map(i) ->> obj); if (pb_non_default_fields(obj) ->> fields) /== [] do fields; endif; endfor %] enddefine; syscancel("pb_current_specs"); define active pb_current_specs; pb_get_current_specs() enddefine; define pb_attributes; pb_map(); enddefine; define updaterof pb_attributes(spec, num); lvars spec num obj = false, l; dlocal sd_incremental = true; if ispb_obj(num) then pb_obj_number(num) -> num endif; if spec == false then /* kill it off */ false -> pb_map(num); elseif islist(spec) and (pb_map(num) ->> obj) then pb_update_obj(obj, spec); else pb_new_obj(if num then [number ^num] :: spec else spec endif) -> obj; pb_show_obj(obj); endif; obj -> pb_spec_obj; enddefine; define active pb_spec; false enddefine; define active pb_specs; false; enddefine; define updaterof active pb_spec(spec); lvars l spec, num = false, obj; dlocal x = false, current_bug current_obj; unless world_initialized do mishap('Bugworld not initialized', [^spec]); endunless; unless world_displayed do pb_refresh() endunless; if ispair(spec) and ispair(spec(1)) and ispair(spec(1)(1)) then spec -> pb_specs; return; endif; if spec matches [==[number ?x]==] then x -> num; elseif spec matches [==[name ?x]==] then if isword(x) and (pb_obj_called(x) ->> obj) do pb_obj_number(obj) else pb_n_objects+1 endif -> num; endif; spec -> pb_attributes(num); enddefine; define updaterof active pb_specs(specs); lvars spec specs; for spec in specs do spec -> pb_spec; endfor; enddefine; define pb_save_world(file); lvars file; pb_get_current_specs() -> valof("datafile")(file); enddefine; define pb_restore_world(file); lvars file; 0 -> pb_new_world; valof("datafile")(file) -> pb_specs; enddefine; /* -- New worlds ------------------------------- */ define pb_set_scores; newproperty([],16,0,true)-> pb_scores_maxval; unless isproperty(pb_scores_map) do newmap([]) -> pb_scores_map; endunless; newmap([]) -> pb_scores; if pb_clip then [] -> pb_clip endif; enddefine; define pb_set_data; pb_cleargensymproperty(); false ->> pb_grid_world ->> pb_grid_line_colour -> pb_grid_world_alignment; [] -> pb_simulation_data; newproperty([],64,false,false) -> pb_obj_with_colour; tl(pb_dark_colours) -> pb_available_colours; true -> pb_simulation_finished; false ->> pb_topbug -> current_bug; cancel_current_selection(); 0 ->> pb_n_objects ->> pb_n_bugs -> pb_update_count; 1 -> pb_cycle_number; newmap([]) -> object_map; identfn ->> pb_cycle_trap ->> pb_response_filter ->> pb_inputs_filter -> pb_outputs_filter; erase ->> pb_show_obj_trap ->> pb_unshow_obj_trap -> pb_obj_selection_trap; enddefine; define pb_set_world; /* init world-related data structures */ lvars c = false, xm = pb_max_coord-2, ym = pb_max_coord-2, pdr; dlocal pb_allow_display_updates = false; pb_set_data(); pb_new_obj([ [name bugworld] [boundary rock] [innards air] [behaviour static] [shape box] [colour black] [position {%pb_max_coord/2, pb_max_coord/2%}] [dimensions [^pb_max_coord ^pb_max_coord]] ]) -> ; true -> world_initialized; if get_simulation_pdr("init") ->> pdr do pdr() endif; if not(pb_topbug) and pb_bug(1) then pb_bug(1) -> pb_topbug endif; enddefine; define pb_reset_world_during_sim; dlocal pb_simulation_finished pb_cycle_trap pb_cycle_number; pb_set_world(); pb_refresh(); enddefine; define pb_quiet_init; dlocal pb_allow_display_updates = false; pb_set_scores(); pb_set_world(); enddefine; define /* lconstant */ check_world_initialized_and_displayed; if not(world_initialized) then pb_init() endif; if not(world_displayed) then pb_refresh() endif; enddefine; define pb_init; pb_quiet_init(); pb_refresh(); enddefine; define pb_set_simulation; -> pb_simulation; pb_init(); enddefine; define pb_first_init; if pb_simulation /= nullstring then pb_show_message([^(lowertoupper(pb_simulation))], true); endif; pb_init(); enddefine; define active pb_new_world; enddefine; define updaterof active pb_new_world(spec); lvars i = 1, spec; lconstant bug_cols = pb_dark_colours; nullstring -> pb_simulation; if ispair(spec) and ispair(spec(1)) then spec -> pb_spec; return endif; if spec == [] then 0 -> spec endif; unless islist(spec) do [^spec 0] -> spec; endunless; repeat spec(1) times [[behaviour ^pb_forwards] % if (i + 1 ->> i) <= length(bug_cols) then [colour %bug_cols(i)%] else [colour blue] endif % [trail_colour MistyRose] % if i == 2 then /* initial bug */ [direction 270]; [position {50 50}]; endif % ] -> pb_spec; endrepeat; repeat spec(2) times [[behaviour static] [position %pb_find_empty_pos({50 50}, 20)%] ] -> pb_spec; endrepeat; enddefine; /* -- Active-vars interface to current bug */ define active pb_current_obj; if ispb_obj(current_obj) then current_obj elseif pb_map(obj_cp_sheet_obj_num) then pb_map(obj_cp_sheet_obj_num) else pb_obs(1) endif; enddefine; define active pb_current_bug; lvars bug; if ispb_obj(current_bug) then current_bug elseif pb_is_bug(pb_map(obj_cp_sheet_obj_num) ->> bug) then bug else pb_bug(1) endif; enddefine; define active pbcb; pb_current_bug enddefine; define pb_check_current_bug; unless ispb_obj(pb_current_bug) do mishap('No current bug', []) endunless; enddefine; define active pb_steps; false; enddefine; define /* lconstant */ apply_pdr_to(obj, pdr); lvars pdr, i o; if obj then pdr(obj) else appproperty(pb_map, procedure(i,o); returnif(i==1); pdr(o) endprocedure); endif; enddefine; define updaterof active pb_steps; lvars steps, n, bug = pb_current_bug, obj, move = false; dlocal current_bug current_obj; -> steps; if steps == "turn" then if dup() > 0 then pb_right_turn else pb_left_turn endif -> move; -> steps; endif; if not(move) then {^(sign(steps) * 0.5) ^(sign(steps) * 0.5)} -> move; endif; pb_check_current_bug(); repeat intof(abs(steps)) times apply_pdr_to(bug, pb_attempt_wheel_rotations(%move%)); endrepeat; enddefine; define active pb_size; pb_obj_dimensions(pb_current_bug)(1) enddefine; define updaterof active pb_size(size); lvars size; pb_check_current_bug(); pb_update_obj(pb_current_bug, [[dimensions {^size ^size}]]); enddefine; define make_bug1_procedures; lvars field, i, pdr, pb_pdr; dlocal pop_pr_quotes = false; for field in pb_field_pdrs do if issubstring(pb_obj_record_prefix, field) ->> i then i + length(pb_obj_record_prefix) -> i; consword(substring(i, length(field)-(i-1), field)) -> field; endif; consword(pb_obj_record_prefix> pdr; consword('pb_'> pb_pdr; syscancel(pb_pdr); [ define active ^pb_pdr; pb_check_current_bug(); ^pdr (pb_current_bug); enddefine; define updaterof active ^pb_pdr (x); /* dlocal pb_allow_display_updates = false; have to show movements */ lvars x, l = [[^field 0]]; x -> l(1)(2); pb_check_current_bug(); pb_update_obj(pb_current_bug, l); enddefine; ].popval endfor; enddefine; make_bug1_procedures(); /* while teach files still contain refs to `procedure/dynamics/ attributes */ define active pb_procedure; pb_behaviour; enddefine; define updaterof active pb_procedure; -> pb_behaviour; enddefine; define active pb_dynamics; pb_behaviour; enddefine; define updaterof active pb_dynamics; -> pb_behaviour; enddefine; define active pb_sensor_inputs; [% explode(pb_get_sensor_inputs(pb_current_bug)) %] enddefine; /* compatibility */ syssynonym("pb_sensory_inputs", "pb_sensor_inputs"); define active pb_action; enddefine; define updaterof active pb_action(action); lvars action; pb_attempt_wheel_rotations(pb_current_bug, action); enddefine; /* -- Built-in action procedures ----------- */ define pb_scale_wheel_rotations(wheel_rotations, s) -> rotations; lvars wheel_rotations, rotations = copy(wheel_rotations), s; rotations(1) * s -> rotations(1); rotations(2) * s -> rotations(2); enddefine; define pb_rotation(bug, angle) -> wheel_rotations; lvars bug, angle, wheel_rotations, a, inc = 0, v; if isdecimal(bug) then bug -> inc; -> bug endif; if isinteger(bug) do pb_map(bug) -> bug endif; (angle / 360) / (get_tracklength(bug) / (obj_width(bug) * pi)) -> a; {%-a + inc, a + inc%} -> wheel_rotations; enddefine; define pb_reorienting_advance(field) -> rotations; /* rotations towards obj in ray-sensor field */ lvars n, inc = 1, col = false, c = 1.5, rotations, m, i; lconstant vec = {0 0}; /* smaller values of constant c produce more rapid turns */ if isnumber(field) then 2 -> inc; field -> col; -> field endif; length(field) -> n; fill(0,0,vec) -> rotations; for i from 1 by inc to n do if field(i) /= 0 and (not(col) or col = field(i+1)) then c + (rotations(1) + (field(i) * (i/n))) -> rotations(1); c + (rotations(2) + (field(i) * ((n-i+1)/n))) -> rotations(2); endif; endfor; if rotations(1) + rotations(2) = 0 then pb_right_turn -> rotations; else (rotations(1) + rotations(2)) * 0.8 -> c; rotations(1)/c -> rotations(1); rotations(2)/c -> rotations(2); endif; enddefine; define pb_reorienting_advance_towards(obj) -> wheel_rotations; /* accesses object's position directly */ lvars wheel_rotations, bug = pb_current_bug, obj, d1, d2 = pb_obj_direction(bug), a; pb_direction_towards(bug, obj) -> d1; pb_angle_between(d1, d2) -> a; if abs(a) > 10 then pb_rotation(bug, sign(a)*8) -> wheel_rotations; else pb_forwards -> wheel_rotations; endif; enddefine; define pb_reorientation(input) -> wheel_rotations; lvars input wheel_rotations = pb_stay_still, i, imax = 0, bug = pb_current_bug, sensors = pb_obj_sensors(bug), v, k = false; for i from 1 to length(input) do if (input(i) ->> v) > imax then v -> imax; i -> k; endif; endfor; if k then pb_rotation(bug, sensors(k)(1)) -> wheel_rotations; endif; enddefine; define pb_try_advance(bug, wheel_rotations); lvars rotations = wheel_rotations, bug; lconstant turn = {0 0}; if not(wheel_rotations) do pb_forwards -> rotations; endif; if not(pb_possible_move(pb_current_bug, rotations)) then pb_possible_move(pb_current_bug, pb_right_turn); endif; enddefine; define pb_select_randomly(forwards, right_turn, left_turn); lvars i = random(1.0), left_turn, right_turn, forwards; pb_try_advance(pb_current_bug, if i > 0.3 do forwards elseif i > 0.15 then left_turn else right_turn endif); enddefine; define pb_random_wheel_rotations; lconstant rotations = {% repeat 8 times valof(pb_standard_wheel_rotations(1)) endrepeat, explode(allbutlast(1,maplist(pb_standard_wheel_rotations, valof))) %}, n = length(rotations); rotations(random(n)) enddefine; define pb_advance_randomly; pb_try_advance(pb_current_bug, pb_random_wheel_rotations()); enddefine; define pb_advance; pb_try_advance(pb_current_bug, pb_forwards); enddefine; define pb_advance_skittishly; pb_select_randomly(pb_forwards, pb_forwards_right_turn, pb_forwards_left_turn) enddefine; vars /* Compatibility */ pb_advance_towards_obj = pb_reorienting_advance, pb_turn_towards_obj = pb_reorientation, pb_advance_on = pb_reorienting_advance_towards; /* -- Actions and moves --------------- */ define pb_store_response(num, input, output); lvars num input n, m = pb_stored_response_input_buffer_length, bug = pb_map(num), input_buffer, output, vec; lconstant cycle = {0}, buffer = {{}}; dlocal pop_pr_quotes = false; if isproperty(pb_responses) and pb_responses(num) then /* pick up inputs the generated this response if we haven't been given them explicitly */ unless input do pb_obj_sensor_inputs_data(bug)(2) -> input; endunless; /* buffer-up input if required */ if input and (length(input) ->> n) and isinteger(m) and ((m+1)*n ->> m) > 0 then if length(buffer(1)) < m then {% repeat m times 0 endrepeat %} -> buffer(1) endif; input <> allbutlast(n, buffer(1)) ->> input -> buffer(1); endif; unless islist(pb_responses(num)) do [] -> pb_responses(num); 0 -> cycle(1); endunless; cycle(1) + 1 -> cycle(1); if cycle(1) mod 100 = 0 do vedputmessage(cycle(1) ><' responses stored'); endif; pb_response_filter({^input ^output}) -> vec; if vec do conspair(vec, pb_responses(num)) -> pb_responses(num);endif; endif; enddefine; define /* lconstant */ update_obj_given_move_to(bug, move, dir, pos); lvars bug move dir pos; lconstant updates = [[direction 0][position 0]], d = tl(hd(updates)), p = tl(updates(2)); if isinteger(bug) do pb_map(bug) -> bug endif; move -> pb_obj_action_data(bug); dir -> fast_front(d); pos -> fast_front(p); pb_update_obj(bug, updates); if pb_responses == true do newproperty([],16,[],false) -> pb_responses endif; if (isproperty(pb_responses) and pb_responses(pb_obj_number(bug))) then pb_store_response(pb_obj_number(bug), false, move); endif; update_trail(bug); enddefine; define pb_state_after_wheel_rotations(bug, wheel_rotations) -> (new_pos, new_dir); lvars bug wheel_rotations, new_pos, new_dir, scaler = 1, bug_i; if isdecimal(bug) do bug -> scaler; -> bug endif; if isinteger(bug) do pb_map(bug) -> bug endif; pb_obj_number(bug) -> bug_i; lvars tracklength = get_tracklength(bug), dims = pb_obj_dimensions(bug), diam = dims(2), radius = diam/2, pos = pb_obj_position(bug), dir = pb_obj_direction(bug), wheel_rotations, l = wheel_rotations(1), r = wheel_rotations(2), L = l, R = r, new_pos = pos, new_dir = dir, angle, rcor, cor_on_right, cor, dis, x, y; while L > radius or R > radius do L*0.01 -> L; R*0.01 -> R; endwhile; if abs(abs(L)-abs(R)) < 0.001 then /* forwards/backwards/swivel wheel_rotations */ if sign(l) == sign(r) then /* forwards/backwards wheel_rotations */ pos(1) -> x; pos(2) -> y; {% pb_rotated_coords(x-(r*tracklength*scaler),y,x,y,dir) %} -> new_pos; elseif diam /= 0 then /* swivel wheel_rotations */ dir + (((r*tracklength*scaler)/(diam * pi))*360) -> new_dir; endif; else /* find new position by trigonometric approximation */ /* decide whether center of rotation is on right or left */ abs(l) > abs(r) -> cor_on_right; /* work out the radius of the circle of rotation (from cor to nearside of bug) */ abs(if cor_on_right then (diam/(L-R))*R else (diam/(R-L))*L endif) -> rcor; /* rotate dir so that it points towards cor */ if cor_on_right then dir-90 else dir+90 endif -> dir; /* generate centre of rotation */ pb_offset_pos(pos, dir, rcor+radius) -> cor; /* work out distance travelled around circum of cor */ (if cor_on_right then l else r endif)*tracklength*scaler -> dis; /* work out angle robot moves through */ (dis/((rcor+radius)*2*pi))*360 -> angle; /* swing dir so that it points from cor to current pos */ dir + 180 -> dir; /* swing it through angle */ if cor_on_right then dir-angle else dir+angle endif -> dir; /* generate new position */ pb_offset_pos(cor, dir, rcor + radius) -> new_pos; /* work out new direction */ if cor_on_right then dir-90 else dir+90 endif -> new_dir; endif; if pb_wraparound then (new_pos(1) mod (pb_max_coord-1)) -> new_pos(1); (new_pos(2) mod (pb_max_coord-1)) -> new_pos(2); endif; pb_legalise_value(bug_i, "position", new_pos) -> new_pos; pb_legalise_value(bug_i, "direction", new_dir) -> new_dir; enddefine; define pb_clear_move_to(bug, pos) -> result; lvars bug, pos, obj, move_dis, dis, d2, a, d1, obj1, result = true, objects = [], b, pos2, s, dir, pdr, bug_i, obj_i; lconstant l = [position 0]; if isinteger(bug) do pb_map(bug) -> bug endif; pb_obj_number(bug) -> bug_i; unless pb_obj_position(bug) do return endunless; /* bug not yet initialised */ if ispair(pos) do {% explode(pos) %} -> pos endif; /* Now check for an obstruction */ if (pb_obstruction_at(bug_i, pos) ->> obj_i) and (pb_map(obj_i) ->> obj) and obj /== bug_initiating_move then if pb_obj_number(obj) /== 1 and pb_is_bug(obj) or (pb_obj_behaviour(obj) ->> b) == "passive" or (isproperty(b) and b("reaction")) then /* shove it out the way! */ pb_direction_towards(pb_obj_position(bug), pos) -> d1; while (pb_obstruction_at(pb_obj_number(bug), pos) ->> obj_i) and (pb_map(obj_i) ->> obj) and pb_obj_number(obj) /== 1 do pb_direction_towards(bug, obj) -> d2; (d1 * 0.7) + (d2 * 0.3) -> dir; /* abs(pb_angle_between(d1, d2)) -> a; 2 * (1 - (a / 180)) -> dis; */ 1 -> dis; bug -> bug_initiating_move; if pb_update_obstructed(obj, [position % pb_offset_pos(pb_obj_position(obj), d2, dis) ->> pos2%]) then false -> result; quitloop; else if isproperty(pb_obj_behaviour(obj) ->> b) and isprocedure(recursive_valof(b("reaction")) ->> b) then b(bug, pos, obj); /* execute reaction procedure */ if pb_simulation_finished and iscaller(pb_do_cycle) then /* bug's reaction has terminated sim */ exitfrom(pb_do_cycle) endif; endif; endif; endwhile; else /* new position is not accessible for some reason */ false -> result; /* if (get_simulation_pdr("update") ->> pdr) and not(iscaller(pdr)) then pdr(); endif; */ if obj == true then pb_map(1) -> obj endif; /* assume external world has same effects as bugworld object */ if not(ispb_obj(obj)) then return endif; if pb_obj_boundary(obj) == "rubber" then pb_update_obj(pb_obj_number(bug), pb_obj_direction(bug) + random(180)); pb_find_empty_pos(pos, 5) -> l(2); pb_update_obj(pb_obj_number(bug), l); elseif isstring(b) then /* special definition of non-bug behaviour */ compile(stringin(s)); endif; endif; endif; enddefine; define /* lconstant */ add_mass(move, last_move, mass) -> move; lvars i, move last_move, mass, max_change = 1 / (mass + 1), cmax, c, d1, d2; lconstant null_move = {0 0}; if not(last_move) do null_move -> last_move endif; max(abs((move(1) - last_move(1)) ->> d1), abs((move(2) - last_move(2))->>d2)) -> cmax; if cmax > max_change then copy(move) -> move; max_change / cmax -> c; subscrv(1, last_move) + (d1 * c) -> subscrv(1, move); subscrv(2, last_move) + (d2 * c) -> subscrv(2, move); endif; enddefine; define pb_attempt_wheel_rotations(bug, wheel_rotations); lvars bug, wheel_rotations, dir, pos1, pos2, n, i, spec, pdr, size, result = false, scaler, record, bug_i; if isnumber(wheel_rotations) then wheel_rotations -> dir; bug -> pos2; "directed_move" -> wheel_rotations; -> bug endif; if isinteger(bug) do pb_map(bug) -> bug endif; pb_obj_number(bug) -> bug_i; if not(bug) do return endif; pb_obj_position(bug) -> pos1; unless (length(wheel_rotations) ->> n) fi_>= 2 and isnumber(wheel_rotations(1)) and isnumber(wheel_rotations(2)) do pb_stay_still -> wheel_rotations; endunless; if pb_motor_noise /== 0 do add_noise(wheel_rotations, pb_motor_noise) -> wheel_rotations; endif; pb_outputs_filter(wheel_rotations) -> wheel_rotations; if (pb_obj_mass(bug) ->> i) /== 0 do add_mass(wheel_rotations, pb_obj_action_data(bug), i); -> wheel_rotations endif; /* in case of an uncleared wheel_rotations, try steps of decreasing size */ wheel_rotations -> pb_obj_action_data(bug); /* will usually be updated by update_obj_given_move_to */ if wheel_rotations == "directed_move" then if (pb_clear_move_to(bug_i, pos2) ->> result) then update_obj_given_move_to(bug_i, wheel_rotations, dir, pos2); endif; else /* try to do as much of the wheel_rotations as poss */ for scaler from 1.0 by -0.1 to 0.1 do if (pb_state_after_wheel_rotations(bug, scaler, wheel_rotations) -> (pos2, dir), pos1 = pos2 or (pb_clear_move_to(bug_i, pos2) ->> result)) then update_obj_given_move_to(bug_i, pb_scale_wheel_rotations(wheel_rotations, scaler), dir, pos2); quitloop; endif; endfor; endif; /* if not(result) then pb_unshow_obj(bug); pb_show_obj(bug); endif;*/ enddefine; /* Compatibility */ vars pb_do_action = pb_attempt_wheel_rotations, pb_do_move = pb_attempt_wheel_rotations; define /* lconstant */ pb_attempt_action(bug, action); lvars bug, bugspec = bug, action n = pdnargs(action); dlocal current_bug; if isinteger(bug) do pb_map(bug) -> bug endif; bug -> current_bug; if n == 0 then action() elseif n == 1 then pb_attempt_wheel_rotations(bugspec, action(pb_get_sensor_inputs(bug))); elseif n == 2 then pb_attempt_wheel_rotations(bugspec, action(bug, pb_get_sensor_inputs(bug))); endif; enddefine; vars lb_learner lb_learned_move; define pb_attempt(bug, action); lvars bug, action, move n = false, pos, result = true, bug_i; dlocal x, current_bug; if isinteger(bug) do pb_map(bug) -> bug endif; pb_obj_number(bug) -> bug_i; bug -> current_bug; if action == true or action == "active" do pb_forwards -> action endif; if isproperty(action) then action("action") -> action endif; if action == lb_learner then pb_attempt_wheel_rotations(bug, lb_learned_move(pb_get_sensor_inputs(bug))) elseif ispair(recursive_valof(action) ->> action) then pb_get_sensor_inputs(bug) -> x; if ispair(hd(action)) then {% applist(action, popval) %} else popval(action) endif -> move; pb_attempt_wheel_rotations(bug_i, move); elseif isvector(action) then pb_attempt_wheel_rotations(bug_i, action) elseif isprocedure(action) then pb_attempt_action(bug_i, action); else mishap('Illegal action', [^action [object number ^(pb_obj_number(bug))]]); endif; enddefine; define pb_activate(bug); lvars updates_map; if isinteger(bug) do pb_map(bug) -> bug endif; pb_attempt(pb_obj_number(bug), pb_obj_behaviour(bug)); enddefine; vars pb_obstructed_action = pb_update_obstructed; define pb_possible_move(bug, move); lvars bug move; not(pb_update_obstructed(bug, move)); enddefine; /* -- Top level procedures (simulation loop) ------------------ */ define pb_do_cycle; /* run one cycle of the simulation */ lvars i, action, input, wd bug, name, pdr, pos, widget, t; lconstant rt = {0}; if isinteger(pb_slow_motion) then repeat pb_slow_motion times endrepeat endif; if isinteger(pb_cycle_time ->> t) or (pb_cycle_time and (1 ->> t)) then until sys_real_time() - rt(1) > t do enduntil; sys_real_time() -> rt(1); endif; unless isinteger(pb_cycle_number) do 1 -> pb_cycle_number endunless; for i to pb_n_objects do if (pb_map(i) ->> bug) and pb_is_bug(bug) and bug /= current_selection(1) and not(pb_coords_out_of_bugworld(pb_obj_position(bug), -10)) then pb_activate(pb_obj_number(bug)); endif; endfor; if get_simulation_pdr("update") ->> pdr do pdr() endif; pb_cycle_number + 1 -> pb_cycle_number; pb_cycle_trap(); if events(current_event_number) then chain(event_handler); endif; if pb_screen_display and vedinputwaiting() then vedinascii() -> pb_simulation_finished; endif; enddefine; define pb_do_cycles(cycles); lvars cycles, v; dlocal pop_pr_quotes = false, pb_allow_display_updates = true; define vars interrupt; true -> pb_simulation_finished; enddefine; check_world_initialized_and_displayed(); if pb_topbug_controller /== "controller" then pb_topbug_controller -> pb_obj_behaviour(pb_bug(1)); endif; false -> pb_simulation_finished; 1 -> pb_cycle_number; until pb_cycle_number > cycles do pb_cycle_number mod pb_display_update_gap == 0 -> pb_allow_display_updates; if pb_cycle_number mod pb_display_refresh_gap == 0 then pb_refresh(); endif; pb_do_cycle(); if isinteger(pb_cycle_pause) do syssleep(pb_cycle_pause) endif; quitif(pb_simulation_finished); enduntil; true -> pb_simulation_finished; if islist(pb_clip) and pb_write_clips then pb_pr('Storing clip in '> pb_datafile(pb_clip_file); vedscreenbell(); endif; enddefine; define active pb_cycles; enddefine; define updaterof active pb_cycles; pb_do_cycles(); enddefine; define pb_run_simulation(cycles); dlocal pb_screen_display; if cycles == false or cycles == "tty" do cycles -> pb_screen_display; -> cycles; endif; pb_do_cycles(cycles); if pb_scores.datalist /== [] do pb_show_scores(); endif; enddefine; /* -- avoidance simulation (single builtin for cut-down system) ----- */ define pb_update_avoidance; lconstant last_pos = consref(false); lvars bug = pb_current_bug, ad, pos, d; unless pb_is_bug(pb_current_bug) do return endunless; pb_obj_position(pb_current_bug) -> pos; if pb_obstruction_at(false, pb_obj_position(bug)) and pb_score_on then pb_score_on('hit frequency') + 1 -> pb_score_on('hit frequency'); elseif cont(last_pos) then pb_distance_between(cont(last_pos), pos) -> d; endif; pos -> cont(last_pos); enddefine; define pb_avoid_obstacles; lvars bug = pb_current_bug, inputs = pb_get_sensor_inputs(bug), i; for i to length(inputs) do if inputs(i) > 0.92 then pb_attempt_wheel_rotations(bug, pb_right_turn); return; endif; endfor; pb_attempt_wheel_rotations(bug, pb_forwards); enddefine; define pb_init_avoidance; lvars bug, i; [ [[position {25 27}][dimensions {25 15}]] [[position {70 75}][dimensions {18 13}]] [[position {78.5 40}][dimensions {10 8}]] [[position {20 55}][dimensions {8 8}]] [[position {25 90}][dimensions {10 10}]] ] -> pb_specs; [[name avoider][direction ^(random(360))] [dimensions [4 4]] [behaviour ^pb_avoid_obstacles] [sensors ^(pb_make_sensors([20],2,40))] [colour blue][trail_colour cyan] [position {50 50}]] -> pb_spec; [[innards mist][colour gainsboro]] -> pb_attributes(1); if pb_score_on then 0 -> pb_score_on('hit frequency'); /* in case it's never updated */ endif; [[training_set_size 80][internal_network_description 3]] -> pb_simulation_data; /* return;*/ procedure(vec) -> vec; lvars vec, input, output; explode(vec) -> (input, output); {% for i to length(input) do if input(i) > 0.915 then "high" else "low" endif endfor %} -> vec(1); if output(1) = 1 and output(2) = 1 then {forward} else {right} endif -> vec(2); endprocedure -> pb_response_filter; enddefine; {pb_init_avoidance pb_update_avoidance} -> pb_simulations("avoidance"); pb_show_logo(); pr_quotes -> pop_pr_quotes; syslibcompile("popbugsinit", popuseslist) ->; unless fullpopbugs == true or isword(fullpopbugs) or (iscaller(ved_l1) and sys_fname_nam(vedpathname) = 'popbugs') do [] -> proglist; endunless; /* -- FULLPOPBUGS (mouse interface etc.) ---------------------------------- */ uses popxlib; uses propsheet; propsheet_init(); /* uses Xpw; doesn't seem to be needed */ include xpt_xgcvalues.ph; uses xt_callback; /* -- Behaviour scores ------------ */ define /* lconstant */ pb_score_on(c); lvars w = consword(c), s = pb_scores(w); if not(s) then 0 else s endif; enddefine; define /* lconstant */ assign_score_for(score, crit, pb_topbug_controller); dlocal pb_topbug_controller; lvars score crit; score -> pb_score_on(crit); enddefine; define updaterof /* lconstant */ pb_score_on(v,c); lvars v c; v -> pb_scores(consword(c)); enddefine; define /* lconstant */ init_scores_for(l); lvars s l; for s in l do unless pb_scores(consword(s)) do 0 -> pb_score_on(s); endunless; endfor; enddefine; define pb_score_maxval(crit); pb_scores_maxval(consword(crit)); enddefine; define updaterof pb_score_maxval(crit); -> pb_scores_maxval(consword(crit)); enddefine; define /* lconstant */ full_criterion(sim, crit); dlocal pop_pr_quotes = false; consword(sim >< space >< crit) enddefine; define /* lconstant */ get_items_from(prop); lvars s = false, prop item val, pdr = false; unless isproperty(prop) do prop -> s; -> prop endunless; unless isproperty(prop) do prop -> pdr; -> prop; endunless; [% appproperty(prop, procedure(item,val); if not(s) or issubstring(s, item) then if pdr do pdr(val) else item endif; endif; endprocedure) %].pb_nodups enddefine; define /* lconstant */ get_all_criteria; lvars sim; [% for sim in pb_simulation_names() do explode(get_items_from(pb_scores_map, sim)) endfor %].pb_nodups enddefine; define /* lconstant */ get_all_controllers; lvars sim; [% for sim in pb_simulation_names() do explode(get_items_from(pb_scores_map, procedure(prop); applist(datalist(prop), hd) endprocedure, sim)) endfor %].pb_nodups enddefine; define /* lconstant */ split_criterion(crit) -> sim -> crit; lvars i; if (locchar(32, 1, crit) ->> i) then consword(substring(1,i-1,crit)) -> sim; consword(substring(i+1,length(crit)-i,crit)) -> crit; endif; enddefine; define /* lconstant */ save_score(score, sim, crit, controller); lvars score crit sim, controller, full_crit = full_criterion(sim, crit); unless isproperty(pb_scores_map(full_crit)) do newproperty([],8,[],true) -> pb_scores_map(full_crit); endunless; (score :: pb_scores_map(full_crit)(controller)) -> pb_scores_map(full_crit)(controller); enddefine; define pb_show_scores; lvars criteria = get_items_from(pb_scores), score, val, crit, crit_word, message = [], i; dlocal pop_pr_quotes = false, pop_pr_places = 4; [^nullstring ^(if pb_simulation /= nullstring do lowertoupper(pb_simulation) >< ' SCORES' else nullstring endif)] -> message; for i to length(criteria) do criteria(i) -> crit_word; criteria(i) >< nullstring -> crit; crit :: message -> message; pb_score_on(crit) -> score; pb_scores_maxval(crit_word) -> val; if val == 0 then pb_max_cycles -> val endif; if isdecimal(score) and val >= score do score / val ->> score -> pb_score_on(crit); endif; if isnumber(score) and not(isinteger(score)) and score /== 0 do number_coerce(score, 1.0) -> score; endif; score :: message -> message; if pb_simulation /= nullstring do save_score(score, pb_simulation, crit_word, pb_topbug_controller); endif; nullstring :: message -> message; endfor; pb_show_message(rev(message)); enddefine; define pb_new_sim_cp_field(field); if pb_sim_cp_sheet then propsheet_field(pb_sim_cp_sheet, field <> [(acceptor = pb_reset_sim_cp_var)]); endif; enddefine; /* -- pursuit simulation ------------------------------ */ define pb_action_for_pursuit(input); lvars iput; pb_reorienting_advance(input) enddefine; define pb_init_pursuit; [[behaviour pb_action_for_pursuit] [name pursuer] [shape tank] [sensors ^(pb_make_sensors([30],7,10))] [innards air] [blind_spots [bugworld]] [direction 250] [dimensions [5 5]] [colour black] [trail_colour gainsboro] [trail_colour same] [position %if pb_topbug_controller=="pb_advance_randomly" then pb_random_pos() else {50 50} endif%]] -> pb_spec; [[behaviour pb_advance_skittishly] [name target] [shape tank] [innards air] [dimensions {6 6}] [sensors ^(pb_make_sensors([15],2,30))] [colour red] [trail_colour MistyRose] [trail_colour same] [direction 270][position {70 30}]] -> pb_spec; [[innards mist][colour PowderBlue]] -> pb_attributes(1); [[training_set_size 300]] -> pb_simulation_data; enddefine; define pb_update_pursuit; lvars d, ad, pursuer = pb_bug(1), target = pb_bug(2); pb_distance_between(pursuer, target) -> d; pb_score_on('mean distance from target') -> ad; (ad * 0.9) + (d * 0.1) -> pb_score_on('mean distance from target'); enddefine; {pb_init_pursuit pb_update_pursuit} -> pb_simulations("pursuit"); /* -- saloon_door simulation -------------------------- */ vars /* lvars */ pb_saloon_door_shut = false, pb_saloon_door_state; define pb_update_saloon_door; lvars pos1, pos2, a = 45, d, d1, d2, ds = [^(270-a, 270+a, 90-a, 90+a)], dlist = [^(for d1 in ds do for d from d1-2 to d1+2 do d endfor, /* pdr; Que??? */endfor )], bug = pb_current_bug, door1 = pb_map(3), door2 = pb_map(4), tc1 = false, /* pb_obj_trail_colour(door1) */, tc2 = false /* pb_obj_trail_colour(door2) */; lconstant directions = {4 -3}; if member(pb_obj_direction(door1), dlist) then if tc1 do valof("oneof")(pb_colours) -> tc1 endif; -directions(1) -> directions(1) endif; if member(pb_obj_direction(door2), dlist) then if tc2 do valof("oneof")(pb_colours) -> tc2 endif; -directions(2) -> directions(2) endif; (pb_obj_direction(door1) + directions(1)) mod 360 -> d1; (pb_obj_direction(door2) + directions(2)) mod 360 -> d2; {% get_rotated_coords(-27, 50, 0, 50, d1) %} -> pos1; {% get_rotated_coords(73, 50, 100, 50, d2) %} -> pos2; pb_update_obj(door1, [[direction ^d1][position ^pos1] %if tc1 do [trail_colour ^tc1] endif %]); pb_update_obj(door2, [[direction ^d2][position ^pos2] %if tc2 do [trail_colour ^tc2] endif %]); abs(d1-180) + abs(d2) < 20 -> pb_saloon_door_shut; if pb_obj_position(bug)(2) < 15 then pb_apply_and_store([pb_show_obj_in("red", pb_current_bug); syssleep(100);]); pb_score_on('passes') + 1 -> pb_score_on('passes'); 0 -> pb_saloon_door_state; pb_update_obj(bug, [^(oneof([95 90 75 80 75 5 10 15 20 25])) 90]); endif; enddefine; define pb_action_for_saloon_door(field) -> action; lvars field action = pb_stay_still, a, bug = pb_current_bug, state = pb_saloon_door_state; if state == 3 then /* going for it! */ pb_forwards -> action elseif state == 2 then /* waiting to go for it */ if pb_saloon_door_shut do pb_forwards -> action; 3 -> state; endif; elseif state == 1 then /* at centre but not pointing right */ pb_angle_between(pb_obj_direction(bug), 270) -> a; if abs(a) < 5 then 2 -> state; elseif a > 0 then {0.05 -0.05} -> action; else {-0.05 0.05} -> action; endif; elseif state == 0 then /* not at centre yet */ if pb_distance_between(bug, {50 90}) < 4 then 1 -> state; elseif (pb_direction_towards(bug, {50 90}) -> a, abs(pb_angle_between(pb_obj_direction(pb_current_bug), a) ->> a)) < 10 then pb_forwards -> action elseif a > 0 then {0.4 0} -> action else {0 0.4} -> action; endif; endif; state -> pb_saloon_door_state; enddefine; define pb_init_saloon_door; lvars pos = {^(oneof([95 90 75 80 75 5 10 15 20 25])) 90}, bug, door_spec = [[shape box] [display_level 1][colour brown][substance impenetrable_shell][trail_colour linen] [dimensions {45 2}]]; [ [[name bar][shape box][colour LightGoldenrod][position {50 5}][dimensions [40 5]]] [[number 3] ^^door_spec [position {27 50}][direction 180]] [[number 4] ^^door_spec [position {73 50}][direction 0]] [[name cowboy][colour blue][dimensions {4 4}] [trail_colour MistyRose] [sensors ^(pb_make_sensors([30],7,10))] [behaviour pb_action_for_saloon_door] [position ^pos] [direction %190 + random(170)%]] ] -> pb_specs; init_scores_for(['crashes' 'passes']); 0 -> pb_saloon_door_state; [[training_set_size 500]] -> pb_simulation_data; [[boundary rock][innards mist][colour aquamarine]] -> pb_attributes(1); enddefine; {pb_init_saloon_door pb_update_saloon_door} -> pb_simulations("saloon_door"); /* -- dynamic-avoidance ---------------------------- */ vars pb_dynamism = 0.7; define da_asteroid_move(input) -> move; lvars move, bug = pb_current_bug, pos = pb_obj_position(bug), x = pos(1), y = pos(2), move, field, l, bug, dims; dlocal pb_allow_display_updates; if x < 10 or y < 10 or x > (pb_max_coord-10) or y > (pb_max_coord-10) then pb_update_obj(bug, [[direction %pb_obj_direction(bug) + 170 %]]); endif; unless pb_dynamism = 0 do {^pb_dynamism ^pb_dynamism} -> move; endunless; enddefine; define da_move(input); lvars input action, i; for i to length(input) do if input(i) > 0.9 then return(pb_right_turn) endif; endfor; pb_forwards; enddefine; define da_reaction(asteroid, pos, bug); lvars asteroid pos bug, dims; pb_obj_dimensions(bug) -> dims; pb_update_obj(bug, [[colour red][dimensions [%dims(1)+2, dims(2)+2%]]]); pb_show_obj(bug); false -> pb_allow_display_updates; pb_update_obj(bug, [[colour blue][dimensions ^dims]]); pb_score_on('hit frequency') + 1 -> pb_score_on('hit frequency'); enddefine; define da_init; lvars bug; [ [name avoider] [direction ^(random(360))] [sensors ^(pb_make_sensors([45],7,15))] [shape triangle] [behaviour ^(newassoc([[action da_move][reaction da_reaction]]))] [colour blue] [trail_colour aquamarine] [position {50 50}] ] -> pb_spec; [% repeat 6 times [[behaviour da_asteroid_move][direction %random(360)%] [dimensions {8 8}][sensors []] [position %pb_find_empty_pos({50 50}, 10)%] [shape circle][colour brown] [trail_colour linen] [substance penetrable_shell]] endrepeat %] -> pb_specs; /* procedure; if pb_cycle_number mod 40 == 0 do pb_dynamism + 0.1 -> pb_dynamism; 'dynamism = '> str; pb_apply_and_store([pb_show_annotation2(^str);]); endif; endprocedure -> pb_cycle_trap; */ 0.3 -> pb_dynamism; 0 -> pb_score_on('hit frequency'); /* in case it's never updated */ 2 -> pb_linesize; pb_new_sim_cp_field([dynamism menuof [0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1]]); enddefine; {da_init} -> pb_simulations("dynamic_avoidance"); /* -- tagbots ----------------- */ vars /* lvars */ tb_map = false, ; define active tb_colours; lvars i; [% for i from 1 to pb_n_objects do pb_obj_colour(pb_map(i)) endfor %] enddefine; define tb_make; lvars n, shape, size, colours, trail_colours, sensors, i, j, a, cols = tl(pb_colours), trail_colours, spread, dw, v, dim, innards, bg_col = false, sensor_angle, tracklength, proximity_weighting; dlocal pop_pr_quotes = false; if (tb_map("number")->>n)=="random" do 1 + random(3) -> n endif; if (tb_map("shape")->>shape)=="random" do oneof(pb_shapes) -> shape endif; if (tb_map("colours")->>colours)=="random" do [] -> colours; endif; if (tb_map("innards")->>innards)=="random" do oneof([air mist]) -> innards; endif; tb_map("tracklength")->tracklength; tb_map("proximity_weighting")-> proximity_weighting; tb_map("sensor_angle")-> sensor_angle; tb_map("size") -> size; define vars tagbot_pdr(x); lvars i, x n = length(x), d = n/2, bias = 0, l = bias, r = bias, op; if x(1) > 0.92 or x(2) > 0.92 then return(pb_right_turn) endif; for i from 3 by 2 to n do if i mod 2 == 1 then nonop + else nonop - endif -> op; op(r, x(i)) -> r; op(l, x(i+1)) -> l; endfor; {%l/d,r/d%} enddefine; [%for i from 0 to n-1 do [ [name %consword('tagbot' >< i)%] [colour %if colours /== [] do destpair(colours)-> colours else oneof(sd_colours) endif %] [trail_colour same] [sensors [% [-15 bugworld]; [15 bugworld]; for j from 1 to n-1 do if ispair(sensors) and tl(sensors) /== [] then destpair(destpair(sensors))->sensors; else if (sensor_angle->>a) == "random" do random(90) -> a endif; if (proximity_weighting->>dw) == "random" do 0.1 + random(0.9) -> dw endif; (i + j) mod n -> v; consword('tagbot' >< v) -> v; [{%a,dw%} ^v]; [{%-a,dw%} ^v]; endif; endfor %]] %if (tracklength ->> a) == "random" do 2 + random(5) -> a endif% [tracklength ^a] [shape ^shape] [behaviour ^tagbot_pdr] [boundary mist] [innards ^innards] [position ^(pb_find_empty_pos_inside(30))] [direction %random(360)%] %if (size ->> a) == "random" do 1 + random(20) -> a endif% [dimensions {%a,a-2%}]] endfor; [[name bugworld] /* [boundary rubber] */ [colour % if colours /== [] do hd(colours) ->> bg_col else oneof(sd_colours) ->> bg_col endif %] % if bg_col == "white" do [innards air] else [innards mist] endif % ] %]; enddefine; define tb_accepter(box, field, value) -> value; lvars box field value, val = value; if isstring(val) do maplist(sysparse_string(val), consword) -> val; endif; val -> tb_map(field); enddefine; define tb_set_cp; lvars col_menu = [ 'red blue yellow LightSteelBlue' 'yellow blue magenta' 'gold green blue3' 'blue yellow aquamarine' 'red green blue' 'violet LightSlateBlue DarkSlateBlue' 'orchid aquamarine yellow NavyBlue' 'SlateBlue yellow LightCyan PaleTurquoise' 'CornflowerBlue navy gold linen' 'black red4 RoyalBlue salmon MediumSeaGreen' ]; propsheet_hide([^pb_sim_cp_sheet]); propsheet_field(pb_sim_cp_sheet, [ [number menuof [random 1 2 3 4 5 6 7 8 9 10] (accepter = ^tb_accepter)] [size menuof [random 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20] ( accepter = ^tb_accepter)] [shape menuof ^("random" :: pb_shapes) ( accepter = ^tb_accepter)] [innards menuof ^("random" :: pb_substances) ( accepter = ^tb_accepter)] [sensor_angle menuof [random 10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180] ( accepter = ^tb_accepter)] [proximity_weighting menuof [random 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9] (accepter = ^tb_accepter)] [tracklength menuof [random 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20] ( accepter = ^tb_accepter)] [colours menuof ^("random" :: col_menu) ( accepter = ^tb_accepter)] ]); propsheet_show([^pb_sim_cp_sheet]); newproperty([],16,"random",false) -> tb_map; enddefine; define tb_init; if not(tb_map) do tb_set_cp(); endif; tb_make() -> pb_specs; enddefine; {tb_init} -> pb_simulations("tagbots"); /* -- pole_balancing ----------- */ vars /* lvars */ last_cart_x = false, cart_acceleration = 0.8, /* motor-drive increment/decrement */ pole_acceleration = 2, /* exponential function of angle */ pole_swing = 0, pole_dir, ; define incline_pole(a, xc); lvars a, xc, pole = pb_map(3), x1, y1, pos = pb_obj_position(pole), x2, y2, d = pb_obj_direction(pole); pos(1) + xc -> pos(1); pb_backmid(pole) -> (x1,y1); pb_obj_position(pole) -> pos; pos(1) -> x2; pos(2) -> y2; pb_rotated_coords(x2,y2,x1,y1,a) -> (x2, y2); d + a -> d; {^x2 ^y2} -> pb_obj_position(pole); d -> pb_obj_direction(pole); enddefine; define pb_update_pole; lvars c, cart = pb_obj_called("cart"), cart_action = pb_obj_action_data(cart), cart_x = pb_obj_position(cart)(1), pole = pb_obj_called("pole"), d = pb_obj_direction(pole), a = d-270, pole_pos = pb_obj_position(pole), pos; if d > 358 or d < 178 then true -> pb_simulation_finished; return; endif; pb_unshow_obj(pole); /* implement gravitational pull */ ((1+(abs(a)/90))**pole_acceleration) * sign(a) -> a; incline_pole(a, 0); /* implement pull from cart motion */ cart_x - last_cart_x -> c; incline_pole(c, c); pb_obj_direction(pole) - d -> pole_swing; /* used by cart behaviour procedure */ pb_show_obj(pole); enddefine; define pb_update_cart(input) -> action; lvars input, action, cart = pb_obj_called("cart"), cart_x = pb_obj_position(cart)(1), c = cart_acceleration, move = pb_obj_action_data(cart); if not(move) then {0 0} ->> move -> pb_obj_action_data(cart) endif; if cart_x < 7 or cart_x > 93 then mishap('Cart has run out of space', []); endif; cart_x -> last_cart_x; if pole_swing > 0 then c else -c endif -> c; move(1) + c -> move(1); move(2) + c -> move(2); copy(move) -> action; enddefine; define pb_init_pole_balancing; 0 -> pole_swing; 271 -> pole_dir; [ [ [name cart] [shape circle] [colour black] [behaviour pb_update_cart] [substance impenetrable_shell] [position [50 82]] [dimensions [10 8]] [direction 0] [sensors []] ] [ [name pole] [colour blue] [trail_colour white] [behaviour pb_update_pole] [boundary mist] [shape box] [dimensions [60 1]] [position [50 50]] [direction ^pole_dir] ] ] -> pb_specs; enddefine; {pb_init_pole_balancing} -> pb_simulations("pole_balancing"); 'null' -> pb_simulation; /* -- Colour palette ------------------------------- */ uses showpalette; define respond_to_palette_event(col, is_selection); lvars col is_selection, i, obj; for i to pb_n_objects do if pb_obj_colour(pb_map(i)->> obj) == "palette" or pb_obj_trail_colour(pb_map(i)->> obj) == "palette" then pb_show_obj(obj); endif; endfor; enddefine; define init_palette; showpalette(palette_display_name, 1, respond_to_palette_event) -> palette_selection; enddefine; /* -- CONTROL PANELS ---------------- */ unless pb_screen_display do [] -> proglist endunless; define active pb_colour_display; sd_allow_colour enddefine; define updaterof active pb_colour_display; -> sd_allow_colour; enddefine; define /* lconstant */ update_sim_cp; if sim_cp_box and pb_sim_cp_sheet then propsheet_field(pb_sim_cp_sheet, [simulation menuof ^(nullstring :: pb_simulation_names())]); /* propsheet_show([^sim_cp_box ^pb_sim_cp_sheet]); */ endif; enddefine; define pb_reset_sim_cp_var(box, field, val) -> val; lvars box field val; dlocal pop_pr_quotes = false; XptDeferApply( procedure(f, v); lvars v f, f1 display widget; if isstring(v) and strnumber(v) then strnumber(v) -> v; endif; if v = 'true' then true -> v elseif v = 'false' then false -> v endif; if isdefined(consword('pb_'>> f1) and not(isundef(valof(f1))) then f1 -> f; elseif isstring(f) then consword(f) -> f; endif; v -> valof(f); if f == "pb_simulation" and not(pb_simulation_finished) then true -> pb_simulation_finished; endif; endprocedure(%field, val%)); XptSetXtWakeup(); enddefine; define /* lconstant */ set_obj_cp_with_last_selection; false -> sys_timer(set_obj_cp_with_last_selection); if pb_isobj(last_selection) then set_obj_cp(pb_obj_number(last_selection)); endif; enddefine; define sim_cp_button_pdr(box, button) -> result; lvars box button result = false; define button_pdr(box, button); lvars box, button, bug; if (pb_map(pb_driven_bug) ->> bug) and button = 'Start/Stop' then cancel_current_selection(); pb_show_caption(); pb_flash_obj(bug); elseif not(pb_simulation_finished) and member(button, [Reset 'Start/Stop']) then true -> pb_simulation_finished; false -> events(new_event_number); elseif button == "Reset" then chain(pb_init); elseif button = 'Start/Stop' then chain(pb_max_cycles, pb_do_cycles); elseif button == "Refresh" then if islist(pb_clip) then [] -> pb_clip; vedputmessage('Emptied clip'); endif; pb_refresh(); set_obj_cp_with_last_selection(); endif; enddefine; XptDeferApply(button_pdr(%box, button%)); XptSetXtWakeup(); enddefine; define /* lconstant */ set_sim_cp; lvars i, vals = [^(for i from 0 by 0.05 to 0.5 do round_to(i,2) endfor)]; if not(sim_cp_box) then propsheet_new_box('POPBUGS Control Panel', false, sim_cp_button_pdr, [Reset 'Start/Stop' Refresh]) -> sim_cp_box; propsheet_new(false,sim_cp_box,false) -> pb_sim_cp_sheet; propsheet_field(pb_sim_cp_sheet, [ [simulation menuof ^(nullstring :: pb_simulation_names())] /* [sensor_noise menuof ^vals] [motor_noise menuof ^vals] [slow_motion menuof [0 100 1000 10000 100000 1000000 10000000]] [display_update_gap menuof [1 2 4 8 16 32 64 99999999]] [display_refresh_gap menuof [1000 500 100 50 20 10000 100000]] [display_number menuof [1 2 3 4 5 6 7 8 9 10]] [wraparound ^pb_wraparound] */ [colour_display ^pb_colour_display] [pb_display_mapped_world ^pb_display_mapped_world] [caption_position menuof [title_bar below side]] ]); for i from 1 to propsheet_length(pb_sim_cp_sheet) do pb_reset_sim_cp_var -> propsheet_field_accepter(pb_sim_cp_sheet, i); endfor; propsheet_show([^sim_cp_box ^pb_sim_cp_sheet]); endif; update_sim_cp(); enddefine; define pb_set_panel; set_sim_cp(); enddefine; define update_all(num, field, v); lvars i, num, field, v, l; if num == 0 then /* obstacles only */ [% for i from 2 to pb_n_objects do if not(pb_is_bug(pb_map(i))) do i endif endfor %] -> l; elseif num == -1 then /* obstacles only */ [% for i to pb_n_objects do if pb_is_bug(pb_map(i)) do i endif endfor %] -> l; elseif pb_map(num) then [% num %] -> l; endif; for i in l do pb_update_obj(pb_map(i), [[^field ^v]]); endfor; enddefine; define /* lconstant */ reset_obj_cp_var(b, field, val) -> val; lvars b, val, v = val, n, obj = true, l = [], i, str; dlocal menu, pb_allow_display_updates; if (field == "number" or (field == "name" and (pb_obj_called(consword(val)) ->> obj) and (pb_obj_number(obj) ->> v))) and n <= pb_n_objects then set_obj_cp(v); elseif val = nullstring then /* value not specified - ignore this field */ propsheet_undef -> val; if field == "label" do true -> val; return endif; else if isstring(val ->> v) then if (strnumber(v) ->> n) then n -> v; if field=="sensors" then pb_make_sensors([%(n div 2) * 20%],n,20) -> v; v sys_>< nullstring -> val; endif; elseif v(1) == `[` or v(1) == `{` then valof("compile")(stringin(v)) -> v; elseunless field == "label" do consword(v) -> v; endif; endif; if v == "palette" and not(palette_selection) do init_palette() endif; if (field == "colour" or field == "trail_colour") and obj_cp_sheet(field) == "palette" then /* 2nd selection */ palette_selection(1) ->> v -> val; if [^field menuof ?menu] isin obj_cp_sheet_attributes and not(fast_lmember(v, menu)) then if hd(menu) = nullstring do v :: menu -> menu else v -> menu(1) endif; propsheet_field(obj_cp_sheet, [^field menuof ^menu]); menu -> it(3); endif; endif; if obj_cp_sheet_obj_num do update_all(obj_cp_sheet_obj_num, field, v); endif; endif; enddefine; define /* lconstant */ update_obj_cp; lvars i = obj_cp_sheet_obj_num, l, obj = pb_map(i), val, pdr, j, field, menu, tag; dlocal pop_pr_quotes = false; if obj_cp_box and obj_cp_sheet then /* reconstruct fields */ if pb_n_objects then /* update flexible menus */ [%nullstring,i,for j to min(20, pb_n_objects) do j endfor; 0; -1; %] -> menu; if menu /= obj_cp_sheet_attributes(1)(3) then propsheet_field(obj_cp_sheet, [number menuof ^menu] ->> l); l -> obj_cp_sheet_attributes(1); endif; [^nullstring ^^pb_types] -> menu; if menu /= obj_cp_sheet_attributes(3)(3) then propsheet_field(obj_cp_sheet, [type menuof ^menu] ->> l); l -> obj_cp_sheet_attributes(3); endif; [^nullstring ^^pb_basic_shapes ^(appproperty(pb_special_shapes, erase))] -> menu; if menu /= obj_cp_sheet_attributes(4)(3) then propsheet_field(obj_cp_sheet, [shape menuof ^menu] ->> l); l -> obj_cp_sheet_attributes(4); endif; endif; for l in obj_cp_sheet_attributes do l(1) -> field; l(2) -> tag; if not(obj) then propsheet_field_default(obj_cp_sheet, l(1)) -> val; else valof(consword(pb_obj_record_prefix> val; if tag == "menuof" then l(3) -> menu; if not(member(val, menu)) then nullstring -> val endif; elseif isnumber(tag) and length(l) >= 3 then if isnumber(val) do round(val) -> val endif; unless isinteger(val) and val >= l(2) and val <= abs(l(3)) do l(2) -> val; endunless; elseif isstring(tag) then val >< '' -> val endif; endif; if val and val /= propsheet_field_value(obj_cp_sheet, l(1)) then val -> propsheet_field_value(obj_cp_sheet, l(1)); endif; endfor; for j from 1 to propsheet_length(obj_cp_sheet) do reset_obj_cp_var -> propsheet_field_accepter(obj_cp_sheet, j); endfor; endif; enddefine; define /* lconstant */ set_obj_cp(i); lvars i, obj, n, col = "yellow", font = '*-i-*-15-*', size = 16; if not(obj_cp_box) then false -> obj_cp_sheet_obj_num; pb_show({box 15 23 75 55 blue}); pb_show({string 20 30 'Setting up' ^size ^col ^font}); pb_show({string 20 40 'control panel, ' ^size ^col ^font}); pb_show({string 20 50 'please wait ...' ^size ^col ^font}); set_sim_cp(); propsheet_new_box('POPBUGS Object Control Panel', false, false, []) -> obj_cp_box; propsheet_new(false, obj_cp_box, false) -> obj_cp_sheet; propsheet_field(obj_cp_sheet, obj_cp_sheet_attributes); propsheet_show([^obj_cp_box ^obj_cp_sheet]); pb_refresh(); endif; i -> obj_cp_sheet_obj_num; update_obj_cp(); enddefine; define pb_get_object_near(pos) -> obj; lvars pos, i, d = 5, obj = false, x, ignorables = []; if isnumber(pos) do pos -> d; -> pos endif; if islist(pos) do pos -> ignorables; -> pos endif; for i from 2 to pb_n_objects do nextunless(((pb_map(i) ->> x) and not(fast_lmember(x, ignorables)) and pb_obj_type(x) /== "pseudo")); if pb_distance_between(pos, pb_obj_position(x)) < d or pb_enclosed_within(pos, x) then x -> obj; pb_distance_between(pos, pb_obj_position(x)) -> d; endif; endfor; enddefine; define /* lconstant */ event_handler; lvars sel = current_selection, selected_obj = sel(1), double_click = false, widget, copied_obj = sel(2), driven_bug = sel(4), modified = sel(5), stretching= false, bug, data, code, x, y, newobj, pos, i, d, a, event, newpos, dir, dims, boundary_click, vec = false, c, swinging, pdr, l, event, obj; dlocal sd_incremental = true; lconstant top_right = {1 1}; if iscaller(event_handler, 1) then return endif; while (events(current_event_number) ->> vec) do false -> events(current_event_number); (current_event_number mod max_event_number) fi_+ 1 -> current_event_number; destvector(vec) -> (widget,x,y,code,); sd_X2U_coords(x,y, pb_display_name) -> (x, y); {% x, y%} -> pos; /* carry out special checks first */ if (pb_coords_out_of_bugworld(pos) ->> boundary_click) then if (pb_map(driven_bug)->>bug) then /* end of drive */ cancel_current_selection(); pb_show_caption(); pb_flash_obj(bug); false -> driven_bug; false -> events(current_event_number); return; endif; propsheet_show(sim_cp_box); endif; if driven_bug then if code>0 and code<4 do pb_attempt_wheel_rotations(pb_map(driven_bug), pb_drive_actions(code)); else /* button coming up or something */ return; endif; goto exit_test; elseif x < 0 and y < 0 then /* top-left corner hot spot! */ if code == 1 then pb_init() elseif code==2 do set_obj_cp(1); endif; true -> pb_simulation_finished; goto exit_test; elseif code == 1 and x < 0 and y > 100 then /* left margin hot spot */ pb_refresh(); goto exit_test; elseif fast_lmember(code, [1 2 3]) then /* some sort of click-selection */ if (pb_get_object_near(pos) ->> newobj) then pb_obj_position(newobj) -> newpos; pb_obj_selection_trap(pb_obj_number(newobj)); if code == 1 then pb_obj_dimensions(newobj) -> dims; elseif code == 2 then newobj -> copied_obj; pb_show_obj(pb_new_obj(pb_obj_number(newobj)) ->> newobj); elseif code == 3 then /* start driven_bug */ pb_spin_bug(newobj); pb_obj_number(newobj) -> driven_bug; endif; fill(newobj, copied_obj, pb_obj_direction(newobj), driven_bug, false, current_selection) ->; /* selects it */ pb_show_caption(); goto exit_test; endif; endif; /* now carry out ordinary checks */ if (code = -1 or code == -2) and selected_obj then /* deselection of selected_obj */ false -> copied_obj; last_selection -> obj; cancel_current_selection(); if selected_obj == obj then /* double click */ set_obj_cp_with_last_selection(); elseif pb_simulation_finished == true do 3e6 -> sys_timer(set_obj_cp_with_last_selection); endif; if code == -2 then pb_refresh(); endif; /* display may be messed up */ elseif code == 1 and not(pb_simulation_finished) then /* a 1-click that didn't select anything, so just end sim */ true -> pb_simulation_finished; goto exit_test; elseif code == 1 and boundary_click then /* start sim */ chain(pb_max_cycles, pb_do_cycles); elseif code == 1 then pb_do_cycle(); elseif code == 2 then pb_new_obj([%if boundary_click do [behaviour static] else [behaviour [[0.5][0.5]]] endif% [position ^pos]]) -> newobj; pb_show_obj(newobj); fill(newobj, false, pb_obj_direction(newobj), driven_bug, false, current_selection) ->; /* selects it */ elseif code == 3 and boundary_click then /* refresh */ pb_refresh(); goto exit_test; elseif code == 3 then /* in-world right-click, move all bugs back one step */ for i from 2 to pb_n_objects do return_to_trail_position(pb_map(i)) endfor; elseif ispb_obj(selected_obj) and (testbit(code,8) or testbit(code,9)) then true -> current_selection(5); /* register that it's been modified */ testbit(code,0) -> stretching; /* test if shift-key down */ testbit(code,2) -> swinging; /* test if control key down */ /* caps-lock key (sets bit 1) still not used... */ pb_background_colour -> c; if stretching and pb_obj_shape(selected_obj) == "ant" do /* show little black frame to make it easier */ show_obj_in_as("black", selected_obj, "box"); show_obj_in_as(c, selected_obj, "box"); endif; pb_unshow_obj(selected_obj); if copied_obj then pb_show_obj(copied_obj) endif; if stretching then 0 -> pb_obj_direction(selected_obj); pos -> newpos; pb_obj_position(selected_obj) -> pos; pb_set_val(selected_obj, "dimensions", [% abs(newpos(1)-pos(1))*2, abs(newpos(2)-pos(2))*2 %]) elseif swinging then pb_direction_towards(selected_obj, pos) -> dir; pb_set_val(selected_obj, "direction", dir); fill(selected_obj, copied_obj, dir, driven_bug, modified, current_selection) -> ; else /* must be just shifting */ pb_set_val(selected_obj, "position", pos); endif; pb_update_count + 1 -> pb_update_count; pb_show_obj(selected_obj); /* make it reappear */ if isprocedure(recursive_valof(pb_obj_update_trap(selected_obj)) ->> pdr) then pdr(selected_obj); endif; endif; exit_test: if driven_bug do pb_do_cycle() endif; endwhile; enddefine; define /* lconstant */ respond_to_event(widget, item, data); lvars widget, vec, item, data, c, code= exacc ^int data, n; lconstant irrelevant_clicks = [0 -3]; if fast_lmember(code, irrelevant_clicks) then return endif; check_world_initialized_and_displayed(); consvector( widget, fast_XptValue(widget, XtN mouseX), fast_XptValue(widget, XtN mouseY), code, 4) -> vec; if (testbit(code,8) or testbit(code,9)) /* dragging/resizing */ and new_event_number fi_> 1 and (events(new_event_number fi_- 1) ->> c) and (c(4) ->> c) and (testbit(c,8) or testbit(c,9)) then /* overwrite previous mouse-drag event */ new_event_number fi_- 1 -> new_event_number; endif; vec -> events(new_event_number); (new_event_number mod max_event_number) fi_+ 1 -> new_event_number; if pb_simulation_finished do XptDeferApply(event_handler); XptSetXtWakeup(); else if (new_event_number fi_- current_event_number ->> n) fi_> 10 do npr(n >< ' events waiting; wrong value for pb_simulation_finished?'); /* something wrong */ endif; /* simulation pdr will call handler automatically */ endif; enddefine; define /* lconstant */ respond_to_new_event; respond_to_event(); enddefine; if not(sim_cp_box) then XtRemoveCallback(sd_Xwidget, XtN buttonEvent, respond_to_new_event, 0); XtRemoveCallback(sd_Xwidget, XtN motionEvent, respond_to_new_event, 0); XtAddCallback(sd_Xwidget, XtN buttonEvent, respond_to_new_event, 0); XtAddCallback(sd_Xwidget, XtN motionEvent, respond_to_new_event, 0); endif; pb_set_panel(); /* -- Clips ------------------- */ define pb_datafile(f); valof("datafile")(f) enddefine; define updaterof pb_datafile(f); dlocal interrupt = identfn, pop_pr_places = 1; -> valof("datafile")(f); enddefine; define pb_apply_and_store(list); lvars list; popval(list); if islist(pb_clip) then list :: pb_clip -> pb_clip endif; enddefine; define active pb_clip_file; dlocal pop_pr_quotes = false; '.pb_'> t; lvars t = false; if readable(pb_clip_file) then pb_datafile(pb_clip_file) -> t; endif; enddefine; define pb_get_clip_of(pb_simulation, pb_topbug_controller); dlocal pb_simulation pb_topbug_controller; pb_get_clip() enddefine; define pb_show_clip(clip); lvars last_frame = false, v, output_type = false, clip, list = [], output_file = false, l1 = false, l2 = false, i; dlocal pop_pr_quotes = false, sd_incremental; define lconstant main_part(v); allbutlast(1, v) enddefine; if isstring(clip) do clip -> output_file; -> clip endif; if isword(clip) do clip -> output_type; -> clip; endif; if isinteger(clip) do clip -> last_frame; -> clip; endif; if clip == true then pb_clip -> clip; endif; unless islist(clip) do vederror('No clip available') endunless; if not(output_type) then true -> sd_incremental endif; if last_frame then if last_frame < 0 then allbutfirst(abs(last_frame), clip) else allbutfirst(length(clip)-last_frame,clip) endif -> clip; endif; if not(output_type) then rev(clip) -> clip endif; for l1 in clip do if isvector(hd(l1)) then if output_type then /* check for an over-write */ if l1 /== [] and l2 and maplist(l1, main_part) = maplist(l2, main_part) then /* ignore it - it's the refresh part */ else for v in l1 do conspair(v, list) -> list endfor; endif; else pb_showdisplay(l1); endif; else popval(l1); endif; if pb_slow_motion == true then vedputmessage('Press any key to show next frame of clip'); rawcharin() ->; elseif isinteger(pb_slow_motion) then repeat pb_slow_motion times endrepeat; endif; l1 -> l2; endfor; if output_type == "w" then pb_pr('Storing clip in '> pb_datafile(pb_clip_file); elseif output_type then pb_showdisplay(list, {% if output_type do output_type endif, if output_file do output_file endif %}); endif; enddefine; define pb_show_clip_of(pb_simulation, pb_topbug_controller); dlocal pb_clip pb_simulation pop_pr_quotes = false, pb_topbug_controller; if (pb_get_clip() ->> pb_clip) then pb_show_clip(false, pb_clip); else vedputmessage('No clip for '> args; pb_show_clip(true, dl(args)); enddefine; define popbugs; enddefine; unless fullpopbugs == "learnbugs" do true -> fullpopbugs; [] -> proglist; endunless; /* -- LEARNBUGS -------------------------------- LIB LEARNBUGS Chris Thornton, Nov 1992 This add-on library lets you use supervised learning algorithms (from LIB LEANERS) to train bugs (from LIB POPBUGS) to reproduce any simulated behaviour. */ uses popbugs; uses learners; maplist(l_learner_list, sys_fname_nam <> consword) -> pb_special_controllers; vars lb_learners = [nearest_neighbours], lb_simulations = [conditional_approach], lb_simulation_cycles = 500, lb_training_epochs = 10000, lb_randomise_training_set = false, lb_produce_testing_set = true, lb_learner = hd(lb_learners), lb_controller = false, lb_learner_mean_error = false, lb_show_learner_rep = false, lb_network_description = false, lb_training_set, lb_responses = [{{0 0}{0}}], /* used to work out input/output arities */ lb_runs = false, lb_variance = 0, lb_abbreviation = newassoc([[pb_advance OACP] [pb_advance_randomly wanderer][soft_means SM] [quickprop QP] [tl_recurrent tl_rec] [nearest_neighbours NN] [cascade_correlation CC][conjgrad BP][pdp_backprop BP][id3 ID3]]), ; vars /* forward declarations */ ved_lbd, ; vars /* lconstant */ compute_average_score, ; vars lb_ms_vars = /* for `ms lb' command */ [ {pb_simulation ^^(nullstring :: (pb_simulation_names()))} {lb_learner ^^pb_special_controllers} {lb_simulation_cycles 100 200 300 500 750 1000 2000 5000} {lb_training_epochs ^false 100 250 500 1000 5000 10000 100000} lb_randomise_training_set ]; /* -- Basic utilities ------------------------------ */ define /* lconstant */ check_learners_loaded; popval([uses learners]); enddefine; define /* lconstant */ active lb_training_set_file; dlocal pop_pr_quotes = false; '.lb_' >< pb_simulation >< '_training_set' enddefine; define /* lconstant */ active lb_learner_caption; dlocal pb_topbug_controller = lb_learner; pb_caption; enddefine; define ved_lbts; dlocal pop_pr_quotes = false; veddo('ved '> x; if isnumber(x) do x < 0 -> neg; substring(1, pop_pr_places+2, number_coerce(abs(x),1.0) >< '0000000') -> x; if neg do '-' >< x >< ' ' else ' ' >< x >< ' ' endif; else x >< ' ' endif -> x; syswrite(dev, x, pop_pr_places+4); endfor; syswrite(dev, '\n', 1); enddefine; define /* lconstant */ write_training_set(ts, file); lvars size = false, m = 0, all_pairs = true, gap = ' ', pair, arrow = {'--> '}, dev, output_n = 0, input_n = 0, input, output, n, vec, new_ts = [], value_lengths; vars /* MATCHER */ x; dlocal pop_pr_quotes = false; if not(file) or file = nullstring do lb_training_set_file -> file; endif; unless ispair(ts) do mishap('No training pairs stored', []) endunless; syscreate(file, 1, "line") -> dev; if lb_randomise_training_set do l_randomise(ts) else rev(ts) endif -> ts; for pair in ts do write_vec(pair(1) <> pair(2), dev); m + 1 -> m; quitif(isinteger(size) and m >= size); endfor; ts -> lb_responses; sysclose(dev); vedputmessage(m >< ' pairs (out of '><') written to ' > collect; -> type endif; for pair in list do if issubstring_lim(type, 1, 1, false, pair(1)) then if collect do pair else pair(2) -> valof(pair(1)); endif; endif; endfor; enddefine; define lb_learner_problem; lvars inputs = length(lb_responses(1)(1)), outputs = length(lb_responses(1)(2)), n = inputs + outputs, ts, ts_file = lb_training_set_file, pairs; dlocal lb_training_epochs, pop_pr_quotes = false; vars x; [ [l_caption {^(pb_simulation >< '-training: ')}] [l_training_set_layout [[1 ^inputs][[^inputs + 1] ^n]]] [l_value_type l_unchanged_value] [l_value_range [0 1]] [[l_input_space l_dimensions] ^inputs] [[l_output_space l_dimensions] ^outputs] [[l_dimensions] ^n] [l_acceptable_mean_error 0.001] [l_acceptable_error_change 0.005] [l_acceptable_error_rate 0.05] [l_epochs ^lb_training_epochs] % extract_assignments('l_', true, pb_simulation_data) % ] -> valof("l_problem_learnprops"); true -> valof("l_all_learnprops_specified"); /* blocks derivation procedures */ if lb_produce_testing_set do valof("l_assign_pairs_evenly")(ts_file); else ts_file -> valof("l_training_set"); endif; enddefine; lb_learner_problem -> learner_problem; /* -- Display procedures --------------------------- */ define /* lconstant */ show_learner_rep(sd_incremental, sd_display_number, com); dlocal sd_incremental; unless isstring(com) do if valof("l_is_connectionist_learner")() do 'l showstate' elseif member(pb_topbug_controller, [id3 c4]) and valof("l_tree_structure") /== [] do 'l showdendro' else false endif -> com; endunless; if com then syssleep(400); veddo(com); syssleep(400); endif; enddefine; /* -- Top-level commands --------------------------- */ define /* lconstant */ ved_savelbrep; dlocal pop_pr_quotes = false; veddo('l saverep '>< lb_learner_caption); enddefine; define active lb_clip_file; dlocal pb_topbug_controller = lb_learner, pop_pr_quotes = false; sysfileok('$learnersdir/'><'.clip'); enddefine; define lb_get_clip -> t; lvars f = lb_clip_file, t = false; dlocal pb_topbug_controller = lb_learner; if readable(f) or readable(pb_clip_file ->> f) then pb_datafile(f) -> t endif; enddefine; define lb_replay_clip_of(sim, lb_learner); lvars sim; dlocal pb_topbug_controller = lb_learner; sim -> pb_simulation; pb_show_clip(false, lb_get_clip()) enddefine; define /* lconstant */ save_learner_rep_if_best; lvars map = pb_scores_map(lb_learner_caption), rates, rate, rate, clip; dlocal pop_pr_quotes = false, interrupt; compute_average_score(full_criterion(pb_simulation, 'mean error'), lb_learner) -> rate; if isnumber(rate) and isnumber(lb_learner_mean_error) and lb_learner_mean_error > rate then l_message(5, 'Learner rep. not best - aborting save', []); return; endif; ved_savelbrep(); if (pb_get_clip_of(pb_simulation, lb_learner) ->> clip) then clip -> pb_datafile(lb_clip_file); endif; veddo('l savelogs '> lb_learner; pb_show_message(['Loading' ^lb_learner]); veddo('lib '>< lb_learner_caption); if is_conn() do 'l showstates 10' elseif lb_learner == "c4" and ispair(l_tree_structure) then 'l showdendro' else false endif -> com; show_learner_rep(false, 1, com); false -> sd_incremental; enddefine; define /* lconstant */ lb_set_learner_problem; dlocal pop_pr_quotes = false, lb_training_epochs, sd_incremental lb_learner_mean_error pb_topbug_controller ; lvars test rate; pb_show_message(['Setting up problem' 'and learner' ^(lb_learner >< nullstring)]); pb_quiet_init(); /* sets pb_obj_sensors which is accessed by learner_problem */ veddo('l set -'); enddefine; define /* lconstant */ lb_learn; dlocal pop_pr_quotes = false, lb_training_epochs, sd_incremental lb_learner_mean_error pb_topbug_controller ; lvars test rate; veddo('lib '> lb_learner_mean_error; /* is lost by reset done below */ unless isnumber(lb_learner_mean_error) do valof("l_mean_error") -> lb_learner_mean_error; endunless; save_learner_rep_if_best(); if pb_simulation /= nullstring then save_score(lb_learner_mean_error, pb_simulation, 'mean error', lb_learner); npr('Saving score '>< lb_learner_mean_error); endif; enddefine; define /* lconstant */ lb_learned_move(input) -> action; lvars action; valof("l_apply")(input, l_compute_internal_output) -> action; unless islist(action) or isvector(action) do pb_stay_still -> action; endunless; enddefine; define /* lconstant */ is_learner(controller); fast_lmember(controller, pb_special_controllers) enddefine; define lb_select; if (valof("menuselect")(pb_simulation_names()) ->> list) /== [] and (maplist(rev(list), consword) ->> lb_simulations) and (valof("menuselect")(pb_special_controllers)->>list) /== [] and (maplist(rev(list), consword) ->> lb_learners) then hd(lb_simulations) -> pb_simulation; hd(lb_learners) -> lb_learner; endif; enddefine; define handle_main_args(arg) -> args -> remainder -> bug -> obj; lvars pop_pr_quotes = false, args = valof("sysparse_string")(arg), arg, remainder = nullstring, w, obj = false, bug = false; dlocal pb_init = identfn; [% for arg in args do if not(isstring(arg)) then arg; remainder >< arg >< space -> remainder; elseif member(consword(arg) ->>w, pb_simulation_names()) then w -> pb_simulation; elseif member(consword(arg) ->>w, pb_controllers <> pb_special_controllers) then w -> lb_learner; elseif (pb_obj_called(w) ->> obj) then if pb_is_bug(obj) do obj -> bug endif; else arg; remainder >< arg >< space -> remainder; endif; endfor %] -> args; enddefine; define /* lconstant */ ved_lb; lvars n = 0, arg = vedargument, args, m = false, responses, s, testdemo = false; dlocal lb_learners, pop_pr_quotes = false, lb_simulations, pb_max_cycles = lb_simulation_cycles, pb_responses, pb_topbug_controller; handle_main_args(arg) -> args -> -> ->; if [training_set_size ?x] isin pb_simulation_data do x -> lb_simulation_cycles; endif; if member('?', args) then lb_select(); delete('?', args) -> args; endif; unless world_initialized and lb_learner do mishap('Simulation and/or learner not specified', []); endunless; if args == [] then veddo('lb demo'); veddo('lb learn'); veddo('lb test'); elseif args(1) = 'demo' then newmap([[^(pb_obj_number(pb_topbug)) 1]]) -> pb_responses; pb_init(); extract_assignments('lb_', pb_simulation_data); pb_run_simulation(lb_simulation_cycles); if (pb_responses(pb_obj_number(pb_topbug)) ->> responses) then write_training_set(responses, lb_training_set_file); endif; elseif args(1) = 'learn' and tl(args) == [] then /* any sim/learner refs should have been handled */ lb_learn() elseif (args(1) = 'test') or (args(1) = 'testdemo' ->> testdemo) and tl(args) == [] then if testdemo then newmap([[^(pb_obj_number(pb_topbug)) 1]]) -> pb_responses; endif; pb_quiet_init(); /* make sure learner restore works ok */ extract_assignments('lb_', pb_simulation_data); if pb_topbug_controller=="controller" do lb_learner -> pb_topbug_controller endif; if is_learner(pb_topbug_controller) then restore_learner_rep(pb_topbug_controller) endif; pb_refresh(); pb_run_simulation(lb_simulation_cycles); if testdemo and (pb_responses(pb_obj_number(pb_topbug))->>responses) then write_training_set(responses, lb_training_set_file); endif; else vedputmessage(args >< ' DOES NOT MAKE SENSE'); endif; enddefine; define ved_lbpsd; lvars n = 0; dlocal cucharout; define vars cucharout(c); if c == `\n` then consstring(n); 0 -> n; else c; n+1->n; endif; enddefine; pb_show_message([% veddo('lbp') %],8); enddefine; define /* lconstant */ ved_lba; /* do analysis of different algorithms & behviours etc. */ dlocal lb_learner, pop_pr_quotes = false, vedscreenbell = identfn, pb_max_cycles = lb_simulation_cycles, pb_clip = true, pb_topbug_controller; vars n; lvars simulation, controller, args = sysparse_string(vedargument), repeats = 1; if member('?', args) then lb_select() endif; if args matches [== ?n:isinteger ==] then n -> repeats endif; check_learners_loaded(); newmap([]) -> pb_scores_map; pb_show_message(['PERFORMANCE ANALYSIS' '-- OF --' ^^lb_simulations '-- BY --' ^^lb_learners], true); repeat repeats times for simulation in lb_simulations do simulation -> pb_simulation; veddo('l setsession'); veddo('lb demo'); for lb_learner in lb_learners do veddo('lb learn '> pb_datafile('.pb_scores_map'); veddo('lbwp'); enddefine; define tryexitto(pdr); lvars pdr; if iscaller(pdr) then clearstack(); exitto(pdr) endif; enddefine; define /* lconstant */ ved_lbdb; /* demo one of the trained behaviurs */ lvars exit_pdr = tryexitto(%ved_lbdb%), arg = vedargument, t = false,w, com, bug, trail_colour, args; dlocal lb_learner, pb_simulation, pb_topbug_controller, lb_simulations, lb_learners, learner_problem = lb_learner_problem; handle_main_args(arg) -> args -> -> ->; if member('?', args) then lb_select(); delete('?', args) -> args; endif; false -> sys_timer(exit_pdr); /* in case the last timer is still going */ if args /== [] then pb_show_message([^(lowertoupper(pb_simulation))]); pb_quiet_init(); pb_current_bug -> bug; false -> pb_attributes(pb_obj_number(bug)); syssleep(200); pb_refresh(); syssleep(300); bug -> pb_map(pb_obj_number(bug)); pb_obj_behaviour(bug) -> pdr; pb_obj_trail_colour(bug) -> trail_colour; pb_update_obj(bug, [[trail_colour background]]); syssleep(200); pb_update_obj(bug, [[display_level 9]]); syssleep(400); 15e6 -> sys_timer(exit_pdr); pb_run_simulation(10000); false -> sys_timer(exit_pdr); syssleep(200); else /* pb_quiet_init(); */ pb_show_message([^(lowertoupper(pb_simulation)) 'demonstration']); endif; t -> sys_timer(exit_pdr); pb_show_clip_of(pb_simulation, 'controller'); false -> sys_timer(exit_pdr); if args /== [] and l_learner then syssleep(200); pb_show_message(['Typical' 'learning curve(s)' 'for' ^pb_simulation]); veddo('l restorelogs 'sys_> sys_timer(exit_pdr); lb_replay_clip_of(pb_simulation, lb_learner); false -> sys_timer(exit_pdr); endfor; pb_show_message(['End of' ^pb_simulation 'demonstration']); syssleep(100); enddefine; define pre_demo; dlocal pb_allow_display_updates = false; lvars i; veddo('pb init avoidance'); [ [[name bugworld][colour gainsboro]] [[name bug1][shape tank][display_level 3][trail_colour background][colour red]] [[name obj2][colour yellow]] ] -> pb_specs; true -> pb_allow_display_updates; pb_show_message([' BUGWORLD' ' PREVIEW']); syssleep(200); pb_refresh(); for i from 2 to pb_n_objects do syssleep(100); pb_flash_obj(pb_map(i)); endfor; veddo('pb 75'); [[name bug1][display_level 1][trail_colour blue]] -> pb_spec; pb_refresh(); veddo('pb 100'); syssleep(200); enddefine; define /* lconstant */ ved_lbd; /* demo the various behaviours */ lvars arg = vedargument; dlocal pop_pr_quotes = false, pb_simulation; dlocal lb_learners, lb_simulations; check_learners_loaded(); if arg = '?' then '' -> arg; lb_select() -> endif; if arg /= nullstring then /* veddo('pb logo'); */ syssleep(400); if arg = '1' then nullstring -> arg; pre_demo(); endif; pb_show_message(['Behaviour' 'learning' 'demo' ^(sysdaytime())]); syssleep(200); endif; for pb_simulation in lb_simulations do veddo('lbdb '> arg endif; endfor; pb_show_message([' THE END'], "red"); syssleep(200); pb_show_message(['For simulation' 'commands, see' 'HELP POPBUGS'], "DarkViolet"); enddefine; /* -- Producing performance tables ---------------------------- */ define /* lconstant */ addup(list); lvars list; if list == [] then 0 else hd(list) + addup(tl(list)) endif; enddefine; define /* lconstant */ nums_in(l); lvars l n; maplist(l, procedure(n); if isnumber(n) then n endif endprocedure) enddefine; define /* lconstant */ average(list) -> mean; lvars list = nums_in(list), mean; if list == [] then 0 else addup(list) / length(list) endif -> mean; enddefine; define /* lconstant */ variance(list); lvars n list mean = average(list); average([% for n in list do abs(n - mean) endfor %]) enddefine; define /* lconstant */ compute_average_score(crit, controller); lvars crit, controller, caption map criteria n criteria scores nums; if pb_scores_map(crit) then appproperty(pb_scores_map(crit), procedure(source, scores); if source = controller then nums_in(scores) -> nums; if nums == [] then exitfrom(nullstring, compute_average_score) endif; length(nums) -> n; if isnumber(lb_runs) do max(n, lb_runs) else n endif -> lb_runs; max(variance(nums), lb_variance) -> lb_variance; exitfrom(average(nums), compute_average_score); endif; endprocedure); endif; return(nullstring); enddefine; define /* lconstant */ acronym(string); lvars first = true, string, str, n, c, limit = false, m = 1; if isinteger(string) do string -> limit; -> string endif; consstring( #| lowertoupper(string(1)); for i from 2 to (length(string) ->> n) do if i < n and (string(i) == ` ` or string(i) == `_`) and isalphacode(string(i+1) ->> c) then if first and string(i) == ` ` do `-`; false -> first; endif; lowertoupper(c); quitif(limit and (m + 1 ->> m) >= limit); endif; endfor |#) enddefine; define /* lconstant */ ved_lbp; lvars criteria = get_all_criteria(), controllers = get_all_controllers(), arg = vedargument, str, cell1_len = 12, cell_len = 8, str_lim, cells, n, list, i, perf, crit, b, dr, driver; dlocal pb_simulation, pb_current_criteria, pop_pr_quotes = false, pop_pr_places = 3, cucharout, vedbreak = false, vedautowrite = false, poplinemax = 200, poplinewidth = poplinemax, pb_topbug_controller, lb_learner; if issubstring('> mr', arg) do vedcharinsert -> cucharout; endif; if issubstring('-', arg) do valof("menuselect")(criteria) -> pb_current_criteria; endif; if length(arg) > 0 and arg(1) == `[` do compile(stringin(vedargument)) -> pb_current_criteria; endif; length(criteria) -> cells; if length(arg) > 0 and (strnumber(substring(1,min(length(arg),2),arg)) ->> arg) do arg -> cell_len endif; cell_len -5 -> str_lim; cell1_len + ((cell_len+1) *cells) -> n; 0 ->> lb_runs -> lb_variance; /* print top line */ nl(1); sp(1); repeat n-2 times pr('-'); endrepeat; sp(1); /* print column heads */ pr('\n|'); sp(cell1_len-2); pr('|'); for crit in criteria do acronym(crit) -> str; pr(str); sp(cell_len - length(str)); pr('|'); endfor; pr('\n'); for pb_topbug_controller in controllers do pr('|'); repeat cell1_len-2 times pr('-') endrepeat; pr('|'); for crit in criteria do repeat cell_len times pr('-') endrepeat; pr('|'); endfor; nl(1); pr('|'); if (lb_abbreviation(pb_topbug_controller) ->> dr) do dr else pb_topbug_controller endif -> driver; pr(driver ->> str); sp(cell1_len-2- length(str)); pr('|'); for crit in criteria do if (compute_average_score(crit, pb_topbug_controller) ->> perf) then space >< perf -> str; pr(str); sp(cell_len - length(str)); pr('|'); else sp(cell_len); pr('|'); endif; endfor; pr('\n'); endfor; /* print bottom line */ pr(space); repeat n-2 times pr('-'); endrepeat; /* print key */ pr('\n\n KEY \n '); controllers(1) -> pb_topbug_controller; for crit in criteria do pr(acronym(crit)); pr(': ' >< crit >< '\n '); pr(space); endfor; npr('\n Simulation cycles: '>< lb_simulation_cycles); npr(' Training set size: '>< valof("l_training_set_size")); /* npr(' Maximum training epochs: '>< lb_training_epochs); npr(' Learning rate: 'sys_>< valof("l_learning_rate")); */ npr(' Runs: '>< lb_runs); npr(' Variance: '>< lb_variance); enddefine; define /* lconstant */ ved_lbpsd; vars x; dlocal vedautowrite = false, %sd_drawing_area("X")% = [30 30 -30 -30]; popval([uses autoformat]); vedapply(veddo(%'do ;lbp > mr; mbe ; text2sd ; l1 ;'%), {''}) -> it; pb_showdisplay(x); enddefine; define /* lconstant */ ved_lbwp; /* save performance table in file */ dlocal cucharout = discappend('.lb_performance_results'); veddo('lbp'); cucharout(termin); enddefine; /* -- Special stuff for SRN learning --------------- */ /* define /* lconstant */ inc_conditional_approach_training; lvars behaviour = "approach", map = newmap([]), inputs = length(pb_obj_sensors(pb_current_bug)), outputs = length(pb_forwards), n = inputs + outputs, behaviour, ts, lines; define vars learner_problem; [ [l_caption {'incremental-conditional_approach: Learning to forage using a SRN'}] [l_training_set_layout [[1 [n-2]] [[n-1] [n]]]] [l_value_type l_unchanged_value] [l_internal_network_description 16] [[l_input_space l_dimensions] ^inputs] [[l_output_space l_dimensions] ^outputs] [[l_dimensions] ^n] [l_acceptable_mean_error 0.00009] [l_acceptable_error_change 0.005] [l_epochs 10000] ] -> l_problem_learnprops; l_assign_pairs_evenly('.lb_'><'_training_set'); enddefine; veddo('lib tl_recurrent'); veddo('l go'); true -> valof("tl_keep_wts_file"); for behaviour in [smooth_approach conditional_approach] do learner_problem(); /* reconstructs training set */ valof("tl_new_run")(); /* writes new data and teach files */ valof("tl_read_wts_file")(); /* reads old masss back into internal net */ consvector(vedreadin('.tl.data'))(3) ==> veddo('continue'); endfor; enddefine; define /* lconstant */ learner_problem; lvars pairs, n_pairs = 500, n_input_vars = 7, val, mx; [ [l_caption {'closeness: '}] [l_value_type l_unchanged_value] [l_internal_network_description 9] [l_value_places 1] [l_epochs 100000] ] -> l_problem_learnprops; {% repeat n_pairs times {{ % 0 -> mx; repeat n_input_vars times if random(1.0) > 0.75 then random(1.0) else 0.0 endif ->> val; max(val, mx) -> mx; endrepeat %} {^mx}}; endrepeat %} -> l_training_set; enddefine; define /* lconstant */ learner_problem; lvars pairs, n_pairs = 500, n_input_vars = 7, val, mx, c, w, a; [ [l_caption {'apparent-width: '}] [l_value_type l_unchanged_value] [l_internal_network_description 9] [l_value_places 1] [l_epochs 100000] ] -> l_problem_learnprops; {% repeat n_pairs times {{ % 0 -> mx; random(1.0) -> c; random(n_input_vars) -> w; random(n_input_vars-w) -> a; repeat a-1 times 0.0 endrepeat; repeat w times c; endrepeat; repeat n_input_vars-(a+(w-1)) times 0.0 endrepeat; %} {^(number_coerce(w/10,1.0))}}; endrepeat %} -> l_training_set; enddefine; */