Permut.pas

Un article de Wikipedia.

Graphes et premier nombre de Ramsey

  1. program permut;
  2.  
  3. const SYSTRAP = $4E4F;
  4.  
  5. type node = 1..255;
  6. listnodeptr=^listnode;
  7. listnode = record
  8. node:node;
  9. next:listnodeptr;
  10. end;
  11. listlistnodeptr=^listlistnode;
  12. listlistnode = record
  13. listnodeptr:listnodeptr;
  14. next:listlistnodeptr;
  15. end;
  16. listlistlistnodeptr=^listlistlistnode;
  17. listlistlistnode = record
  18. size:node;
  19. listlistnodeptr:listlistnodeptr;
  20. next:listlistlistnodeptr;
  21. end;
  22. link = record
  23. node1:node;
  24. node2:node;
  25. end;
  26. listlinkptr=^listlink;
  27. listlink=record
  28. link:link;
  29. next:listlinkptr;
  30. end;
  31. listlistlinkptr=^listlistlink;
  32. listlistlink=record
  33. listlinkptr:listlinkptr;
  34. next:listlistlinkptr;
  35. end;
  36. listlistlistlinkptr=^listlistlistlink;
  37. listlistlistlink=record
  38. size:node;
  39. listlistlinkptr:listlistlinkptr;
  40. next:listlistlistlinkptr;
  41. end;
  42. UInt32 = 0..MaxInt;
  43.  
  44. var perms:listlistlistnodeptr;
  45. links:listlistlistlinkptr;
  46. listperm:listlistnodeptr;
  47. l,actual:listlistlinkptr;
  48. n,count,size:integer;
  49. s:node;
  50. c:char;
  51.  
  52. function TimGetSeconds:UInt32; inline(SYSTRAP,$A0F5);
  53. function StrAToI(const S:string):integer; inline(SYSTRAP,$a0ce);
  54.  
  55. function fact(n:integer):integer;
  56. begin
  57. if n >= 0 then
  58. begin
  59. if n = 0 then fact:=1
  60. else
  61. if n = 1 then fact:=1
  62. else fact:=n*fact(n-1);
  63. end
  64. else
  65. fact:=-1;
  66. end;
  67.  
  68. function copyperm(perm:listnodeptr):listnodeptr;
  69. var actual,copyactual:listnodeptr;
  70. begin
  71. if perm <> nil then
  72. begin
  73. actual:=perm;
  74. new(copyactual);
  75. copyperm:=copyactual;
  76. while actual^.next <> nil do
  77. begin
  78. copyactual^.node:=actual^.node;
  79. new(copyactual^.next);
  80. copyactual:=copyactual^.next;
  81. actual:=actual^.next;
  82. end;
  83. copyactual^.node:=actual^.node;
  84. copyactual^.next:=nil;
  85. end
  86. else
  87. copyperm:=nil;
  88. end;
  89.  
  90. function addnode(perm:listnodeptr;n:node;pos:integer):listnodeptr;
  91. var actual,prec,newnode:listnodeptr;
  92. actualpos:integer;
  93. begin
  94. if pos >= 0 then
  95. begin
  96. prec:=nil;
  97. actual:=perm;
  98. actualpos:=0;
  99. while (actual^.next <> nil) and (actualpos <> pos) do
  100. begin
  101. prec:=actual;
  102. actual:=actual^.next;
  103. actualpos:=actualpos+1;
  104. end;
  105. new(newnode);
  106. newnode^.node:=n;
  107. if actualpos = pos then
  108. begin
  109. if prec <> nil then
  110. begin
  111. prec^.next:=newnode;
  112. newnode^.next:=actual;
  113. addnode:=perm;
  114. end
  115. else
  116. begin
  117. newnode^.next:=perm;
  118. addnode:=newnode;
  119. end;
  120. end
  121. else
  122. begin
  123. actual^.next:=newnode;
  124. newnode^.next:=nil;
  125. addnode:=perm;
  126. end;
  127. end
  128. else
  129. addnode:=perm;
  130. end;
  131.  
  132. function addnode2(list:listnodeptr;n:node):listnodeptr;
  133. var actual:listnodeptr;
  134. begin
  135. if list <> nil then
  136. begin
  137. actual:=list;
  138. while (actual^.next <> nil) and (actual^.node <> n) do
  139. actual:=actual^.next;
  140. if actual^.node <> n then
  141. begin
  142. new(actual^.next);
  143. with actual^.next^ do
  144. begin
  145. node:=n;
  146. next:=nil;
  147. end;
  148. end;
  149. addnode2:=list;
  150. end
  151. else
  152. begin
  153. new(actual);
  154. with actual^ do
  155. begin
  156. node:=n;
  157. next:=nil;
  158. end;
  159. addnode2:=actual;
  160. end;
  161. end;
  162.  
  163. function delnode(list:listnodeptr;n:node):listnodeptr;
  164. var actual,prev:listnodeptr;
  165. begin
  166. if list <> nil then
  167. begin
  168. prev:=nil;
  169. actual:=list;
  170. while (actual^.next <> nil) and (actual^.node <> n) do
  171. begin
  172. prev:=actual;
  173. actual:=actual^.next;
  174. end;
  175. if actual^.node = n then
  176. begin
  177. if prev <> nil then
  178. begin
  179. if actual^.next <> nil then
  180. prev^.next:=actual^.next
  181. else
  182. prev^.next:=nil;
  183. dispose(actual);
  184. delnode:=list;
  185. end
  186. else
  187. begin
  188. if actual^.next <> nil then
  189. prev:=actual^.next
  190. else
  191. prev:=nil;
  192. dispose(actual);
  193. delnode:=prev;
  194. end;
  195. end
  196. else
  197. delnode:=list;
  198. end
  199. else
  200. delnode:=nil;
  201. end;
  202.  
  203. procedure erasenode(list:listnodeptr);
  204. var actual,prev:listnodeptr;
  205. begin
  206. if list <> nil then
  207. begin
  208. actual:=list;
  209. while actual^.next <> nil do
  210. begin
  211. prev:=actual;
  212. actual:=actual^.next;
  213. dispose(prev);
  214. end;
  215. dispose(actual);
  216. end;
  217. end;
  218.  
  219. function nodesize(list:listnodeptr):integer;
  220. var actual:listnodeptr;
  221. result:integer;
  222. begin
  223. result:=0;
  224. if list <> nil then
  225. begin
  226. actual:=list;
  227. while actual^.next <> nil do
  228. begin
  229. result:=result+1;
  230. actual:=actual^.next;
  231. end;
  232. result:=result+1;
  233. end;
  234. nodesize:=result;
  235. end;
  236.  
  237. function permutation(n:node):listlistnodeptr;
  238. var actualperms:listlistlistnodeptr;
  239. actuallistperm,copylistperm,lastcopylistperm:listlistnodeptr;
  240. i:node;
  241. reverse:boolean;
  242. pos:integer;
  243. begin
  244. if perms = nil then
  245. begin
  246. new(perms);
  247. with perms^ do
  248. begin
  249. size:=1;
  250. new(listlistnodeptr);
  251. with listlistnodeptr^ do
  252. begin
  253. new(listnodeptr);
  254. with listnodeptr^ do
  255. begin
  256. node:=1;
  257. next:=nil;
  258. end;
  259. next:=nil;
  260. end;
  261. next:=nil;
  262. end;
  263. end;
  264. if n>= 1 then
  265. begin
  266. actualperms:=perms;
  267. while (actualperms^.next <> nil) and (actualperms^.size <> n) do
  268. actualperms:=actualperms^.next;
  269. if n = actualperms^.size then
  270. begin
  271. permutation:=actualperms^.listlistnodeptr;
  272. end
  273. else if n = actualperms^.size+1 then
  274. begin
  275. new(actualperms^.next);
  276. with actualperms^.next^ do
  277. begin
  278. size:=n;
  279. new(listlistnodeptr);
  280. permutation:=listlistnodeptr;
  281. copylistperm:=listlistnodeptr;
  282. next:=nil;
  283. end;
  284. reverse:=true;
  285. actuallistperm:=actualperms^.listlistnodeptr;
  286. while actuallistperm^.next <> nil do
  287. begin
  288. for i:=1 to n do
  289. begin
  290. if reverse then pos:=n-i
  291. else pos:=i-1;
  292. copylistperm^.listnodeptr:=addnode(copyperm(actuallistperm^.listnodeptr),n,pos);
  293. new(copylistperm^.next);
  294. copylistperm:=copylistperm^.next;
  295. end;
  296. actuallistperm:=actuallistperm^.next;
  297. reverse:=not reverse;
  298. end;
  299. for i:=1 to n do
  300. begin
  301. if reverse then pos:=n-i
  302. else pos:=i-1;
  303. copylistperm^.listnodeptr:=addnode(copyperm(actuallistperm^.listnodeptr),n,pos);
  304. new(copylistperm^.next);
  305. lastcopylistperm:=copylistperm;
  306. copylistperm:=copylistperm^.next;
  307. end;
  308. dispose(lastcopylistperm^.next);
  309. lastcopylistperm^.next:=nil;
  310. end
  311. else
  312. begin
  313. actuallistperm:=permutation(n-1);
  314. permutation:=permutation(n);
  315. end;
  316. end
  317. else
  318. permutation:=nil;
  319. end;
  320.  
  321. procedure permprint(perm:listnodeptr);
  322. var actual:listnodeptr;
  323. begin
  324. write('[');
  325. if perm <> nil then
  326. begin
  327. actual:=perm;
  328. while actual^.next <> nil do
  329. begin
  330. write(actual^.node,',');
  331. actual:=actual^.next;
  332. end;
  333. write(actual^.node);
  334. end;
  335. write(']');
  336. end;
  337.  
  338. procedure listpermprint(listperm:listlistnodeptr);
  339. var actual:listlistnodeptr;
  340. n:integer;
  341. begin
  342. writeln('Permutations :');
  343. if listperm <> nil then
  344. begin
  345. n:=1;
  346. actual:=listperm;
  347. while actual^.next <> nil do
  348. begin
  349. write(n:3,':');
  350. permprint(actual^.listnodeptr);
  351. write(' ');
  352. if (n-1) mod 2 = 1 then writeln;
  353. actual:=actual^.next;
  354. n:=n+1;
  355. end;
  356. write(n:3,':');
  357. permprint(actual^.listnodeptr);
  358. writeln;
  359. end
  360. else
  361. writeln('-');
  362. writeln;
  363. end;
  364.  
  365. function isequal(linka,linkb:link):boolean;
  366. begin
  367. if (linka.node1 = linkb.node1) and
  368. (linka.node2 = linkb.node2) or
  369. (linka.node1 = linkb.node2) and
  370. (linka.node2 = linkb.node1) then
  371. isequal:=true
  372. else
  373. isequal:=false;
  374. end;
  375.  
  376. function linksize(links:listlinkptr):integer;
  377. var actual:listlinkptr;
  378. size:integer;
  379. begin
  380. if links <> nil then
  381. begin
  382. size:=1;
  383. actual:=links;
  384. while actual^.next <> nil do
  385. begin
  386. size:=size+1;
  387. actual:=actual^.next;
  388. end;
  389. linksize:=size;
  390. end
  391. else
  392. linksize:=0;
  393. end;
  394.  
  395. function addlink(list:listlinkptr;l:link):listlinkptr;
  396. var actual:listlinkptr;
  397. begin
  398. if list <> nil then
  399. begin
  400. actual:=list;
  401. while (actual^.next <> nil) and not isequal(actual^.link,l) do
  402. actual:=actual^.next;
  403. if not isequal(actual^.link,l) then
  404. begin
  405. new(actual^.next);
  406. with actual^.next^ do
  407. begin
  408. link:=l;
  409. next:=nil;
  410. end;
  411. end;
  412. addlink:=list;
  413. end
  414. else
  415. begin
  416. new(actual);
  417. with actual^ do
  418. begin
  419. link:=l;
  420. next:=nil;
  421. end;
  422. addlink:=actual;
  423. end;
  424. end;
  425.  
  426. function dellink(list:listlinkptr;l:link):listlinkptr;
  427. var actual,prev:listlinkptr;
  428. begin
  429. if list <> nil then
  430. begin
  431. prev:=nil;
  432. actual:=list;
  433. while (actual^.next <> nil) and not isequal(actual^.link,l) do
  434. begin
  435. prev:=actual;
  436. actual:=actual^.next;
  437. end;
  438. if isequal(actual^.link,l) then
  439. begin
  440. if prev <> nil then
  441. begin
  442. if actual^.next <> nil then
  443. prev^.next:=actual^.next
  444. else
  445. prev^.next:=nil;
  446. dispose(actual);
  447. dellink:=list;
  448. end
  449. else
  450. begin
  451. if actual^.next <> nil then
  452. prev:=actual^.next
  453. else
  454. prev:=nil;
  455. dispose(actual);
  456. dellink:=prev;
  457. end;
  458. end
  459. else
  460. dellink:=list;
  461. end
  462. else
  463. dellink:=nil;
  464. end;
  465.  
  466. procedure eraselink(list:listlinkptr);
  467. var actual,prev:listlinkptr;
  468. begin
  469. if list <> nil then
  470. begin
  471. actual:=list;
  472. while actual^.next <> nil do
  473. begin
  474. prev:=actual;
  475. actual:=actual^.next;
  476. dispose(prev);
  477. end;
  478. dispose(actual);
  479. end;
  480. end;
  481.  
  482. function haslink(list:listlinkptr;l:link):boolean;
  483. var actual:listlinkptr;
  484. begin
  485. if list <> nil then
  486. begin
  487. actual:=list;
  488. while (actual^.next <> nil) and not isequal(actual^.link,l) do
  489. actual:=actual^.next;
  490. if not isequal(actual^.link,l) then
  491. haslink:=false
  492. else
  493. haslink:=true;
  494. end
  495. else
  496. haslink:=false;
  497. end;
  498.  
  499. function issame(list1,list2:listlinkptr):boolean;
  500. var actual:listlinkptr;
  501. begin
  502. if linksize(list1) = linksize(list2) then
  503. begin
  504. if list1 <> nil then
  505. begin
  506. actual:=list1;
  507. while (actual^.next <> nil) and haslink(list2,actual^.link) do
  508. begin
  509. actual:=actual^.next;
  510. end;
  511. if haslink(list2,actual^.link) then
  512. issame:=true
  513. else
  514. issame:=false;
  515. end
  516. else
  517. issame:=true;
  518. end
  519. else
  520. issame:=false
  521. end;
  522.  
  523. function copylink(list:listlinkptr):listlinkptr;
  524. var actual,copyactual:listlinkptr;
  525. begin
  526. if list <> nil then
  527. begin
  528. actual:=list;
  529. new(copyactual);
  530. copylink:=copyactual;
  531. while actual^.next <> nil do
  532. begin
  533. copyactual^.link.node1:=actual^.link.node1;
  534. copyactual^.link.node2:=actual^.link.node2;
  535. new(copyactual^.next);
  536. copyactual:=copyactual^.next;
  537. actual:=actual^.next;
  538. end;
  539. copyactual^.link.node1:=actual^.link.node1;
  540. copyactual^.link.node2:=actual^.link.node2;
  541. copyactual^.next:=nil;
  542. end
  543. else
  544. copylink:=nil;
  545. end;
  546.  
  547. function alllinks(size:node):listlinkptr;
  548. var n1,n2:node;
  549. actual,prev:listlinkptr;
  550. begin
  551. if size > 1 then
  552. begin
  553. new(actual);
  554. alllinks:=actual;
  555. for n1:=1 to size do
  556. for n2:=1 to size do
  557. if n2 > n1 then
  558. begin
  559. actual^.link.node1:=n1;
  560. actual^.link.node2:=n2;
  561. new(actual^.next);
  562. prev:=actual;
  563. actual:=actual^.next;
  564. end;
  565. prev^.next:=nil;
  566. dispose(actual);
  567. end
  568. else
  569. alllinks:=nil;
  570. end;
  571.  
  572. function addlistlink(list:listlistlinkptr;l:listlinkptr):listlistlinkptr;
  573. var actual:listlistlinkptr;
  574. begin
  575. if list <> nil then
  576. begin
  577. actual:=list;
  578. while (actual^.next <> nil) and not issame(actual^.listlinkptr,l) do
  579. actual:=actual^.next;
  580. if not issame(actual^.listlinkptr,l) then
  581. begin
  582. new(actual^.next);
  583. with actual^.next^ do
  584. begin
  585. listlinkptr:=l;
  586. next:=nil;
  587. end;
  588. end;
  589. addlistlink:=list;
  590. end
  591. else
  592. begin
  593. new(actual);
  594. with actual^ do
  595. begin
  596. listlinkptr:=l;
  597. next:=nil;
  598. end;
  599. addlistlink:=actual;
  600. end;
  601. end;
  602.  
  603. function dellistlink(list:listlistlinkptr;l:listlinkptr):listlistlinkptr;
  604. var actual,prev:listlistlinkptr;
  605. begin
  606. if list <> nil then
  607. begin
  608. prev:=nil;
  609. actual:=list;
  610. while (actual^.next <> nil) and not issame(actual^.listlinkptr,l) do
  611. begin
  612. prev:=actual;
  613. actual:=actual^.next;
  614. end;
  615. if issame(actual^.listlinkptr,l) then
  616. begin
  617. if prev <> nil then
  618. begin
  619. if actual^.next <> nil then
  620. prev^.next:=actual^.next
  621. else
  622. prev^.next:=nil;
  623. dispose(actual);
  624. dellistlink:=list;
  625. end
  626. else
  627. begin
  628. if actual^.next <> nil then
  629. prev:=actual^.next
  630. else
  631. prev:=nil;
  632. dispose(actual);
  633. dellistlink:=prev;
  634. end;
  635. end
  636. else
  637. dellistlink:=list;
  638. end
  639. else
  640. dellistlink:=nil;
  641. end;
  642.  
  643. function listlinksize(links:listlistlinkptr):integer;
  644. var size:integer;
  645. actual:listlistlinkptr;
  646. begin
  647. if links <> nil then
  648. begin
  649. size:=0;
  650. actual:=links;
  651. while actual^.next <> nil do
  652. begin
  653. size:=size+1;
  654. actual:=actual^.next;
  655. end;
  656. size:=size+1;
  657. listlinksize:=size;
  658. end
  659. else
  660. listlinksize:=-1;
  661. end;
  662.  
  663. function toperm(perm:listnodeptr;n:node):integer;
  664. var pos:integer;
  665. actual:listnodeptr;
  666. begin
  667. if perm <> nil then
  668. begin
  669. if n >= 1 then
  670. begin
  671. pos:=1;
  672. actual:=perm;
  673. while (actual^.next <> nil) and (n <> pos) do
  674. begin
  675. actual:=actual^.next;
  676. pos:=pos+1;
  677. end;
  678. if n = pos then
  679. toperm:=actual^.node
  680. else
  681. toperm:=0;
  682. end
  683. else
  684. toperm:=0;
  685. end
  686. else
  687. toperm:=0;
  688. end;
  689.  
  690. function linkperm(links:listlinkptr;perm:listnodeptr):listlinkptr;
  691. var actual,copyactual:listlinkptr;
  692. begin
  693. if links <> nil then
  694. begin
  695. if perm <> nil then
  696. begin
  697. new(copyactual);
  698. linkperm:=copyactual;
  699. actual:=links;
  700. while actual^.next <> nil do
  701. begin
  702. with copyactual^ do
  703. begin
  704. link.node1:=toperm(perm,actual^.link.node1);
  705. link.node2:=toperm(perm,actual^.link.node2);
  706. new(next);
  707. copyactual:=next;
  708. end;
  709. actual:=actual^.next;
  710. end;
  711. with copyactual^ do
  712. begin
  713. link.node1:=toperm(perm,actual^.link.node1);
  714. link.node2:=toperm(perm,actual^.link.node2);
  715. next:=nil;
  716. end;
  717. end
  718. else
  719. linkperm:=copylink(links);
  720. end
  721. else
  722. linkperm:=nil;
  723. end;
  724.  
  725. function complink(l:listlinkptr;n:node):listlinkptr;
  726. var result,actual:listlinkptr;
  727. begin
  728. if n >= 2 then
  729. begin
  730. result:=alllinks(n);
  731. if l <> nil then
  732. begin
  733. actual:=l;
  734. while actual^.next <> nil do
  735. begin
  736. result:=dellink(result,actual^.link);
  737. actual:=actual^.next;
  738. end;
  739. result:=dellink(result,actual^.link);
  740. end;
  741. complink:=result;
  742. end
  743. else
  744. complink:=nil;
  745. end;
  746.  
  747. function nblink(n:node):integer;
  748. begin
  749. if n >= 0 then
  750. nblink:=n*(n-1) div 2
  751. else
  752. nblink:=0;
  753. end;
  754.  
  755. procedure linkprint(l:link);
  756. begin
  757. write('(');
  758. if l.node1 <= l.node2 then
  759. write(l.node1,',',l.node2)
  760. else
  761. write(l.node2,',',l.node1);
  762. write(')');
  763. end;
  764.  
  765. procedure listlinkprint(links:listlinkptr);
  766. var actual:listlinkptr;
  767. begin
  768. write('[');
  769. if links <> nil then
  770. begin
  771. actual:=links;
  772. while actual^.next <> nil do
  773. begin
  774. linkprint(actual^.link);
  775. write(',');
  776. actual:=actual^.next;
  777. end;
  778. linkprint(actual^.link);
  779. end;
  780. writeln(']');
  781. end;
  782.  
  783. procedure listlistlinkprint(links:listlistlinkptr);
  784. var actual:listlistlinkptr;
  785. begin
  786. if links <> nil then
  787. begin
  788. actual:=links;
  789. while actual^.next <> nil do
  790. begin
  791. listlinkprint(actual^.listlinkptr);
  792. actual:=actual^.next;
  793. end;
  794. listlinkprint(actual^.listlinkptr);
  795. end
  796. else
  797. writeln('-');
  798. end;
  799.  
  800. function getlinks(size:node;n:integer):listlistlinkptr;
  801. var actuallistlistlist:listlistlistlinkptr;
  802. actuallistlist,prevlistlist,result,temp:listlistlinkptr;
  803. actuallist,alllistlink,copylist:listlinkptr;
  804. permlist,actualpermlist:listlistnodeptr;
  805. begin
  806. if links = nil then
  807. begin
  808. new(links);
  809. with links^ do
  810. begin
  811. size:=2;
  812. listlistlinkptr:=addlistlink(nil,nil);
  813. listlistlinkptr:=addlistlink(listlistlinkptr,complink(nil,2));
  814. next:=nil;
  815. end;
  816. end;
  817. if size >= 2 then
  818. begin
  819. if n < 0 then
  820. getlinks:=getlinks(size,0)
  821. else
  822. if n > nblink(size) then
  823. getlinks:=getlinks(size,nblink(size))
  824. else
  825. begin
  826. actuallistlistlist:=links;
  827. while (actuallistlistlist^.next <> nil) and (actuallistlistlist^.size <> size) do
  828. actuallistlistlist:=actuallistlistlist^.next;
  829. if actuallistlistlist^.size = size then
  830. begin
  831. actuallistlist:=actuallistlistlist^.listlistlinkptr;
  832. if actuallistlist <> nil then
  833. begin
  834. result:=nil;
  835. while actuallistlist^.next <> nil do
  836. begin
  837. if linksize(actuallistlist^.listlinkptr) = n then
  838. result:=addlistlink(result,actuallistlist^.listlinkptr);
  839. actuallistlist:=actuallistlist^.next;
  840. end;
  841. if linksize(actuallistlist^.listlinkptr) = n then
  842. result:=addlistlink(result,actuallistlist^.listlinkptr);
  843. if result <> nil then
  844. getlinks:=result
  845. // n list not found
  846. else
  847. begin
  848. if n > (nblink(size) div 2) then
  849. begin
  850. prevlistlist:=getlinks(size,nblink(size)-n);
  851. if prevlistlist <> nil then
  852. begin
  853. actuallistlist:=prevlistlist;
  854. result:=nil;
  855. while actuallistlist^.next <> nil do
  856. begin
  857. result:=addlistlink(result,complink(actuallistlist^.listlinkptr,size));
  858. actuallistlist:=actuallistlist^.next;
  859. end;
  860. result:=addlistlink(result,complink(actuallistlist^.listlinkptr,size));
  861. actuallistlist:=actuallistlistlist^.listlistlinkptr;
  862. while actuallistlist^.next <> nil do
  863. actuallistlist:=actuallistlist^.next;
  864. actuallistlist^.next:=result;
  865. getlinks:=getlinks(size,n);
  866. end
  867. else
  868. begin
  869. writeln('getlinks: generate error');
  870. getlinks:=nil;
  871. end;
  872. end
  873. // n <= nblink(size) div 2
  874. else
  875. begin
  876. prevlistlist:=getlinks(size,n-1);
  877. if prevlistlist <> nil then
  878. begin
  879. alllistlink:=alllinks(size);
  880. // temp will contain one more link than previous links found
  881. temp:=nil;
  882. actuallistlist:=prevlistlist;
  883. while actuallistlist^.next <> nil do
  884. begin
  885. actuallist:=alllistlink;
  886. while actuallist^.next <> nil do
  887. begin
  888. if not haslink(actuallistlist^.listlinkptr,actuallist^.link) then
  889. temp:=addlistlink(temp,addlink(copylink(actuallistlist^.listlinkptr),actuallist^.link));
  890. actuallist:=actuallist^.next;
  891. end;
  892. if not haslink(actuallistlist^.listlinkptr,actuallist^.link) then
  893. temp:=addlistlink(temp,addlink(copylink(actuallistlist^.listlinkptr),actuallist^.link));
  894. actuallistlist:=actuallistlist^.next;
  895. end;
  896. actuallist:=alllistlink;
  897. while actuallist^.next <> nil do
  898. begin
  899. if not haslink(actuallistlist^.listlinkptr,actuallist^.link) then
  900. temp:=addlistlink(temp,addlink(copylink(actuallistlist^.listlinkptr),actuallist^.link));
  901. actuallist:=actuallist^.next;
  902. end;
  903. if not haslink(actuallistlist^.listlinkptr,actuallist^.link) then
  904. temp:=addlistlink(temp,addlink(copylink(actuallistlist^.listlinkptr),actuallist^.link));
  905. // filter same links when permuted
  906. permlist:=permutation(size);
  907. result:=nil;
  908. while temp <> nil do
  909. begin
  910. // listlistlinkprint(temp);
  911. //write('add ');
  912. //listlinkprint(temp^.listlinkptr);
  913. result:=addlistlink(result,temp^.listlinkptr);
  914. copylist:=temp^.listlinkptr;
  915. actualpermlist:=permlist;
  916. while (actualpermlist^.next <> nil) and (temp <> nil) do
  917. begin
  918. actuallist:=linkperm(copylist,actualpermlist^.listnodeptr);
  919. //writeln('temp');
  920. // listlistlinkprint(temp);
  921. //writeln('perm');
  922. // permprint(actualpermlist^.listnodeptr);
  923. //writeln('linkperm');
  924. // listlinkprint(actuallist);
  925. //read(c);
  926. temp:=dellistlink(temp,actuallist);
  927. actualpermlist:=actualpermlist^.next;
  928. end;
  929. if temp <> nil then
  930. begin
  931. actuallist:=linkperm(copylist,actualpermlist^.listnodeptr);
  932. // listlinkprint(actuallist);
  933. temp:=dellistlink(temp,actuallist);
  934. end;
  935. end;
  936. // result:=temp;
  937. if result <> nil then
  938. begin
  939. actuallistlist:=actuallistlistlist^.listlistlinkptr;
  940. while actuallistlist^.next <> nil do
  941. actuallistlist:=actuallistlist^.next;
  942. actuallistlist^.next:=result;
  943. getlinks:=result;
  944. end
  945. else
  946. begin
  947. writeln('getlinks: generate error 3');
  948. getlinks:=nil;
  949. end;
  950. end
  951. else
  952. begin
  953. writeln('getlinks: generate error 2');
  954. getlinks:=nil;
  955. end;
  956. end;
  957. // writeln('generated result');
  958. end;
  959. end
  960. // listlistlinkptr not initialized
  961. else
  962. begin
  963. writeln('getlinks:listlistlinkptr init error');
  964. getlinks:=nil;
  965. end;
  966. end
  967. //size not found
  968. else
  969. begin
  970. new(actuallistlistlist^.next);
  971. actuallistlistlist^.next^.size:=size;
  972. with actuallistlistlist^.next^ do
  973. begin
  974. listlistlinkptr:=addlistlink(nil,nil);
  975. listlistlinkptr:=addlistlink(listlistlinkptr,complink(nil,size));
  976. next:=nil;
  977. end;
  978. getlinks:=getlinks(size,n);
  979. end;
  980. end;
  981. end
  982. else
  983. getlinks:=nil;
  984. end;
  985.  
  986. function nodes(links:listlinkptr):listnodeptr;
  987. var actual:listlinkptr;
  988. result:listnodeptr;
  989. begin
  990. result:=nil;
  991. if links <> nil then
  992. begin
  993. actual:=links;
  994. while actual^.next <> nil do
  995. begin
  996. with actual^ do
  997. begin
  998. result:=addnode2(result,link.node1);
  999. result:=addnode2(result,link.node2);
  1000. end;
  1001. actual:=actual^.next;
  1002. end;
  1003. with actual^ do
  1004. begin
  1005. result:=addnode2(result,link.node1);
  1006. result:=addnode2(result,link.node2);
  1007. end;
  1008. end;
  1009. nodes:=result;
  1010. end;
  1011.  
  1012. // neighbours of node
  1013. function gamma(links:listlinkptr;n:node):listnodeptr;
  1014. var actual:listlinkptr;
  1015. result:listnodeptr;
  1016. begin
  1017. result:=nil;
  1018. if links <> nil then
  1019. begin
  1020. actual:=links;
  1021. while actual^.next <> nil do
  1022. begin
  1023. with actual^ do
  1024. begin
  1025. if (link.node1 = n) and (link.node2 <> n) then
  1026. result:=addnode2(result,link.node2);
  1027. if (link.node2 = n) and (link.node1 <> n) then
  1028. result:=addnode2(result,link.node1);
  1029. end;
  1030. actual:=actual^.next;
  1031. end;
  1032. with actual^ do
  1033. begin
  1034. if link.node1 = n then
  1035. result:=addnode2(result,link.node2);
  1036. if link.node2 = n then
  1037. result:=addnode2(result,link.node1);
  1038. end;
  1039. end;
  1040. gamma:=result;
  1041. end;
  1042.  
  1043. function hasnode(list:listnodeptr;n:node):boolean;
  1044. var actual:listnodeptr;
  1045. begin
  1046. hasnode:=false;
  1047. if list <> nil then
  1048. begin
  1049. actual:=list;
  1050. while (actual^.next <> nil) and (actual^.node <> n) do
  1051. actual:=actual^.next;
  1052. if actual^.node = n then
  1053. hasnode:=true;
  1054. end;
  1055. end;
  1056.  
  1057. function limitlinks(link:listlinkptr;n:listnodeptr):listlinkptr;
  1058. var actual,result:listlinkptr;
  1059. begin
  1060. result:=nil;
  1061. if link <> nil then
  1062. begin
  1063. if n <> nil then
  1064. begin
  1065. actual:=link;
  1066. while actual^.next <> nil do
  1067. begin
  1068. with actual^ do
  1069. begin
  1070. if hasnode(n,link.node1) and hasnode(n,link.node2) then
  1071. result:=addlink(result,link);
  1072. end;
  1073. actual:=actual^.next;
  1074. end;
  1075. with actual^ do
  1076. begin
  1077. if hasnode(n,link.node1) and hasnode(n,link.node2) then
  1078. result:=addlink(result,link);
  1079. end;
  1080. end
  1081. else
  1082. result:=copylink(link);
  1083. end;
  1084. limitlinks:=result;
  1085. end;
  1086.  
  1087. // clique
  1088. function omega(link:listlinkptr):listnodeptr;
  1089. var result,n,v,c:listnodeptr;
  1090. l:listlinkptr;
  1091. actual:node;
  1092. begin
  1093. result:=nil;
  1094. if link <> nil then
  1095. begin
  1096. n:=nodes(link);
  1097. if nodesize(n) = 2 then
  1098. with n^ do
  1099. begin
  1100. result:=addnode2(result,node);
  1101. result:=addnode2(result,next^.node);
  1102. end
  1103. else
  1104. begin
  1105. while n <> nil do
  1106. begin
  1107. // clique candidat
  1108. c:=nil;
  1109. v:=gamma(link,n^.node);
  1110. if nodesize(v) = 1 then
  1111. c:=addnode2(c,v^.node)
  1112. else
  1113. begin
  1114. l:=limitlinks(link,v);
  1115. c:=omega(l);
  1116. eraselink(l);
  1117. end;
  1118. c:=addnode2(c,n^.node);
  1119.  
  1120. erasenode(v);
  1121.  
  1122. if nodesize(c) > nodesize(result) then
  1123. begin
  1124. erasenode(result);
  1125. result:=c;
  1126. end
  1127. else
  1128. erasenode(c);
  1129.  
  1130. n:=delnode(n,n^.node);
  1131. end;
  1132. end;
  1133. end
  1134. else
  1135. result:=addnode2(result,1);
  1136. omega:=result;
  1137. end;
  1138.  
  1139. procedure pause;
  1140. var c:char;
  1141. begin
  1142. write('Introduisez un caractere');
  1143. readln(c);
  1144. end;
  1145.  
  1146. procedure viewstats;
  1147. var n:node;
  1148. a,count,size:integer;
  1149. t:UInt32;
  1150. begin
  1151. clrscr;
  1152. writeln('Statistiques');
  1153. writeln('------------');
  1154. writeln;
  1155. write('noeud ');
  1156. write('arrete ');
  1157. write('graphe ');
  1158. write('perm. ');
  1159. write('graphe diff.');
  1160. writeln;
  1161. for n:=1 to 38 do
  1162. write('-');
  1163. writeln;
  1164. for n:=2 to 6 do
  1165. begin
  1166. // noeud
  1167. write(n:5);
  1168. // arrete
  1169. write(nblink(n):7);
  1170. // graphe
  1171. write((1 shl nblink(n)):7);
  1172. // permutation
  1173. write(fact(n):6);
  1174. // graphe different
  1175. t:=timgetseconds;
  1176. count:=0;
  1177. for a:=0 to nblink(n) do
  1178. begin
  1179. size:=listlinksize(getlinks(n,a));
  1180. count:=count+size;
  1181. end;
  1182. write(count:6);
  1183. write(' (',timgetseconds-t,')');
  1184. writeln;
  1185. end;
  1186. writeln;
  1187. writeln;
  1188. writeln('noeud  : n');
  1189. writeln('arrete : n*(n-1)/2');
  1190. writeln('graphe : 2^(n*(n-1)/2)');
  1191. writeln('perm.  : n!');
  1192. writeln('graphe diff. : permutation des graphes');
  1193. writeln;
  1194. end;
  1195.  
  1196. procedure viewperm(n:node);
  1197. var i:integer;
  1198. actual:listlistnodeptr;
  1199. begin
  1200. clrscr;
  1201. if (n >= 2) and (n <= 6) then
  1202. begin
  1203. actual:=permutation(n);
  1204. i:=1;
  1205. while actual^.next <> nil do
  1206. begin
  1207. write(i:4,': ');
  1208. permprint(actual^.listnodeptr);
  1209. if i mod 2 = 0 then
  1210. writeln;
  1211. if i mod 40 = 0 then
  1212. pause;
  1213. i:=i+1;
  1214. actual:=actual^.next;
  1215. end;
  1216. write(i:4,': ');
  1217. permprint(actual^.listnodeptr);
  1218. writeln;
  1219. end
  1220. else
  1221. writeln('-');
  1222. end;
  1223.  
  1224. procedure viewgraphe(s:node;a:integer);
  1225. var i:integer;
  1226. actual:listlistlinkptr;
  1227. begin
  1228. clrscr;
  1229. writeln('Graphe reduit');
  1230. writeln('-------------');
  1231. writeln;
  1232. if (s >= 2) and (s <= 6) then
  1233. if (a >= 0) and (a <= nblink(s)) then
  1234. begin
  1235. writeln('noeud ',s:1,' arrete ',a:2);
  1236. writeln('-----------------');
  1237. writeln;
  1238. write('nombre : ');
  1239. actual:=getlinks(s,a);
  1240. writeln(listlinksize(actual));
  1241. writeln;
  1242. if actual <> nil then
  1243. begin
  1244. i:=9;
  1245. while actual^.next <> nil do
  1246. begin
  1247. listlinkprint(actual^.listlinkptr);
  1248. if i mod 20 = 0 then
  1249. pause;
  1250. i:=i+1;
  1251. actual:=actual^.next;
  1252. end;
  1253. listlinkprint(actual^.listlinkptr);
  1254. end
  1255. else
  1256. begin
  1257. listlinkprint(nil);
  1258. end;
  1259. end
  1260. else
  1261. writeln('-')
  1262. else
  1263. writeln('-');
  1264. end;
  1265.  
  1266. procedure viewramsey;
  1267. var n:node;
  1268. a:integer;
  1269. l:listlistlinkptr;
  1270. found,continue:boolean;
  1271. begin
  1272. clrscr;
  1273. writeln('Nombre de Ramsey(3,3)');
  1274. writeln('---------------------');
  1275. writeln;
  1276. found:=false;
  1277. n:=2;
  1278. while (n <= 6) and not found do
  1279. begin
  1280. write('Noeud : ',n);
  1281. continue:=true;
  1282. a:=0;
  1283. write(' arrete :');
  1284. while (a <= (nblink(n) div 2)) and continue do
  1285. begin
  1286. write(' ',a);
  1287. l:=getlinks(n,a);
  1288. while (l^.next <> nil) and continue do
  1289. begin
  1290. if (nodesize(omega(l^.listlinkptr)) < 3) and (nodesize(omega(complink(l^.listlinkptr,n))) < 3) then
  1291. continue:=false;
  1292. l:=l^.next;
  1293. end;
  1294. if continue then
  1295. if (nodesize(omega(l^.listlinkptr)) < 3) and (nodesize(omega(complink(l^.listlinkptr,n))) < 3) then
  1296. continue:=false;
  1297. if continue then
  1298. a:=a+1
  1299. else
  1300. writeln(' non');
  1301. end;
  1302. if continue then
  1303. begin
  1304. found:=true;
  1305. writeln(' oui');
  1306. end
  1307. else
  1308. n:=n+1;
  1309. end;
  1310. writeln;
  1311. if found then
  1312. writeln('Nombre de Ramsey(3,3) = ',n)
  1313. else
  1314. writeln('Ramsey(3,3) pas trouve pour n <= ',n);
  1315. writeln;
  1316. end;
  1317.  
  1318. procedure viewmenu;
  1319. var s:string;
  1320. n,a:integer;
  1321. select:integer;
  1322. continue:boolean;
  1323. begin
  1324. continue:=true;
  1325. while continue do
  1326. begin
  1327. repeat
  1328. clrscr;
  1329. writeln(' Menu');
  1330. writeln(' ----');
  1331. writeln;
  1332. writeln(' 1: Permutations');
  1333. writeln(' 2: Graphes reduits');
  1334. writeln(' 3: Ramsey(3,3)');
  1335. writeln(' 4: Statistique');
  1336. writeln(' 9: Quitter');
  1337. writeln;
  1338. write(' Selection : ');
  1339. readln(s);
  1340. select:=StrAtoI(s);
  1341. until select in [1..4,9];
  1342. writeln;
  1343. case select of
  1344. 1:
  1345. begin
  1346. repeat
  1347. write('Nombre de noeuds [2..6] : ');
  1348. readln(s);
  1349. n:=StrAtoI(s);
  1350. until n in [2..6];
  1351. viewperm(n);
  1352. pause;
  1353. end;
  1354. 2:
  1355. begin
  1356. repeat
  1357. write('Nombre de noeuds [2..6] : ');
  1358. readln(s);
  1359. n:=StrAtoI(s);
  1360. until n in [2..6];
  1361. repeat
  1362. write('Nombre d''arretes [0..',nblink(n),'] : ');
  1363. readln(s);
  1364. a:=StrAtoI(s);
  1365. until a in [0..nblink(n)];
  1366. viewgraphe(n,a);
  1367. pause;
  1368. end;
  1369. 3:
  1370. begin
  1371. viewramsey;
  1372. pause;
  1373. end;
  1374. 4:
  1375. begin
  1376. viewstats;
  1377. pause;
  1378. end;
  1379. 9:
  1380. begin
  1381. continue:=false;
  1382. writeln('A bientot');
  1383. writeln;
  1384. end;
  1385. end;
  1386. end;
  1387. pause;
  1388. end;
  1389.  
  1390. begin
  1391. viewmenu;
  1392. end.