program ioi94day2prb2ver3(input, output, inp, out); { Tom Verhoeff, Eindhoven University of Technology } { Backtracking with cut-off and sorted candidate list } { General Section } const Test = true ; Trace = false ; var inp, out: text ; procedure Init ; begin if Test then writeln('IOI''94 - Day 2 - Problem 2: The Buses') ; assign(inp, 'input.txt') ; reset(inp) ; assign(out, 'output.txt') ; rewrite(out) ; if Test then writeln('Initialized') end { Init } ; procedure Fini ; begin close(inp) ; close(out) end { Fini } ; { Problem Specific Section } type BusRoute = record first : 0..29; interval: 1..59; { first < interval < 59 - first } howoften: 2..60; { howoften = (60 - first) div interval } end; procedure WriteTimes(var f: text); var i, j: integer; begin for i:=0 to 5 do for j:=0 to 9 do write(f, i:1) ; writeln(f) ; for i:=0 to 5 do for j:=0 to 9 do write(f, j:1) ; writeln(f) end { WriteTimes } ; procedure GraphBusRoute(var f: text; b: BusRoute); var i: integer; begin with b do begin write(f, 1:first+1) ; i := first + interval ; while (i <= 59) do begin write(f, 1:interval) ; i := i + interval end { while } ; write(f, ' ':62-i+interval) ; writeln(f, '[', first:2, ',', interval:2, ',', howoften:2, ']') end { with } end { GraphBusRoute } ; var s: integer; { s = sum a[0..59] } a: array[0..59] of integer; { a[t] = # unaccounted arrivals at time t } procedure GraphUnaccounted(var f: text); var h, i, j: integer; begin WriteTimes(f) ; for i:=0 to 5 do for j:=0 to 9 do begin h := a[10*i+j] ; if (h = 0) then write(f, ' ') else if (h < 10) then write(f, h:1) else write(f, chr(ord('A') + h - 10)) end { for j } ; writeln(f, ' total = ', s:1) end { GraphUnaccounted } ; procedure ReadInput; { read input into s and a } var i, j: integer; begin if Test then writeln('Reading input') ; readln(inp, s) ; if Test then writeln('Number of stops = ', s:1) ; for i:=0 to 59 do a[i] := 0 ; for i:=1 to s do begin read(inp, j) ; inc(a[j]) end { for i } ; readln(inp) ; if Test then begin GraphUnaccounted(out) ; writeln end end { ReadInput } ; function Fits(b: BusRoute): boolean; { check whether b fits with a, that is, all arrivals of b occur in a } { global: a } var i, j: integer; begin with b do begin i := first ; j := 60 ; { bounded linear search for earliest a[first + k*interval] = 0 } while i < j do if a[i] <> 0 then i := i+interval else j := i ; Fits := (i >= 60) end { with } end { Fits } ; var n: integer; { # candidate bus routes } c: array[0..899] of BusRoute; { c[0..n-1] are candidate bus routes } procedure FindBusRoutes; { post: c[0..n-1] are all bus routes fitting with a } { global: a, n, c } var f, i, j, k: integer; b: BusRoute; begin if Test then begin writeln('Finding candidate bus routes') ; WriteTimes(out) end { if } ; n := 0 ; for f:=0 to 29 do begin if a[f] <> 0 then begin for i:=f+1 to 59-f do begin with c[n] do begin first := f ; interval := i ; howoften := 1 + (59 - f) div i end { with c[n] } ; if Fits(c[n]) then begin if Test then GraphBusRoute(out, c[n]) ; { insert c[n] into c[0..n-1] to keep sorted on howoften } j := 0 ; k := n ; while j <> k do if c[k-1].howoften < c[k].howoften then begin b := c[k-1] ; c[k-1] := c[k] ; c[k] := b ; dec(k) end { then } else j := k ; inc(n) end { if } end { for i } end { if } end { for f } ; if Test then begin writeln('Number of candidate bus routes = ', n:1) ; if Trace then for j:=0 to n-1 do with c[j] do writeln(first:4, ' ', interval:2, ' ', howoften:2) end { if } end { FindBusRoutes } ; type Schedule = array [0..16] of BusRoute; procedure WriteSchedule(var f: text; sc: Schedule; len: integer); var i: integer; begin for i:=0 to len-1 do with sc[i] do writeln(f, first:2, ' ', interval:2) ; if Test then writeln(f, '-----') end { WriteSchedule } ; var t: longint; { # schedules found so far } freq: array [1..17] of longint; { freq[p] = # schedules with p bus routes } p: integer; { # buses in partial schedule so far } m: integer; { # buses in best schedule so far } sched: Schedule; { sched[0..p-1] is schedule so far } best: Schedule; { best[0..m-1] is best schedule so far } procedure WriteFrequencies(var f: text); var i: integer; begin writeln(f, 'Frequency table for schedule lengths:') ; write(f, ' Len:') ; for i := 1 to 17 do if freq[i] <> 0 then write(f, i:4) ; writeln(f, 'total':6) ; write(f, ' # :') ; for i := 1 to 17 do if freq[i] <> 0 then write(f, freq[i]:4) ; writeln(f, t:6) end { WriteFrequencies } ; procedure ScheduleFound; { pre: p < m } { global: s, a, t, p, m, sched, best } begin if Test then begin inc(t) ; inc(freq[p]) ; WriteSchedule(out, sched, p) end { if } ; m := p ; best := sched ; if Test then begin writeln('Best schedule so far:') ; WriteSchedule(output, best, m) end { if } end { ScheduleFound } ; procedure Use(b: BusRoute); { global: s, a, p, sched } var i: integer; begin sched[p] := b ; inc(p) ; with b do begin i := first ; while (i <= 59) do begin dec(a[i]) ; i := i+interval end { while } ; s := s - howoften end { with } ; if Trace then begin WriteSchedule(output, sched, p) ; GraphUnaccounted(output) end { if } end { Use } ; procedure RemoveLast; { global: s, a, p, sched } var i: integer; begin dec(p) ; with sched[p] do begin i := first ; while (i <= 59) do begin inc(a[i]) ; i := i+interval end { while } ; s := s + howoften end { with } end { Remove } ; procedure FindBestSchedule(k: integer); { global: s, a, n, c, p, sched, m, best } { Find all schedules sched[0..r-1] with p <= r < m such that bus routes sched[0..p-1] are as given, sched[p..r-1] accounts for a and uses only bus routes from c[k..n-1] } { pre: p < m } begin if s = 0 then { nothing left to account for } ScheduleFound else { try each candidate c[k..n-1] that fits } while (k < n) and (p+1 <> m) do begin if Fits(c[k]) then begin Use(c[k]) ; FindBestSchedule(k) ; RemoveLast end { if } ; inc(k) end { while } end { FindBestSchedule } ; procedure ComputeAnswer; begin FindBusRoutes ; if Test then writeln('Finding schedules') ; for p:=1 to 16 do freq[p] := 0 ; t := 0 ; p := 0 ; m := 18 ; FindBestSchedule(0) ; if Test then begin writeln('Number of schedules = ', t:1) ; WriteFrequencies(out) end { if } end { ComputeAnswer } ; procedure WriteOutput; var i: integer; begin if (m > 17) then writeln('More than 17 bus routes') else begin if Test then begin for i:=0 to m-1 do GraphBusRoute(out, best[i]) ; writeln('Smallest number of bus routes = ', m:1) ; WriteSchedule(output, best, m) end { if } ; WriteSchedule(out, best, m) end { else } end { WriteOutput } ; begin Init ; ReadInput ; ComputeAnswer ; WriteOutput ; Fini end.