Turbo Pascal Examples.
Пасьянс "Косынка"

Графика:
Построение графика функции
Прыгающий по экрану мячик.
Качание маятника.
Вложенные цветные круги.
Броуновское движение. Использование объектов.
Матрицы и массивы:
Сортировка элементов массива.
Удаление одинаковых элементов.
Простой пример на поворот матрицы.
Сортировка методом Шелла. +функции измерения временных интервалов.
Проверка выпуклости многоугольника.
Перемоножение матриц
Вычисление определителя матрицы. Рекурсия.
Нахождение обратной матрицы.
Задача об автостоянке.
Рекурсия. Подземелье сокровищ.
Численные методы:
Задачка на определение угла между стрелками часов.
Проверка на принадлежность точки многоугольнику.
Нахождение точки пересечения двух отрезков на плоскости.
Сортировка методом Шелла. +функции измерения временных интервалов.
Сортировка методом "пузырька". Пример на динамические структуры данных. Связанные списки.
Нахождение корня функции методом половинного деления.
Вычисление арккосинуса
Нахождение суммы цифр натурального числа.
Работа с фалами:
Рекурсивное сканирование директорий.
Работа со строками:
Работа со словами в предложении с разделителями.
Простейший синтаксический анализатор для распознавания и вычисления многчлена.
Синтаксический анализатор для распознавания и вычисления многчлена.
Работа со строками: смена кодировки, удаление тегов из HTML текста, обработка
Переименование файлов из кириллицы в латиницу.
Выдача контекстной подсказки.
Частотный словарь символов.
Подсчет повторяющихся символов в строке.
Ссылочные переменные:
Моделирование стека.
Пасьянс "Косынка".
Игры:
Пасьянс "Косынка".
Игра "Питон"
Игра "Анацефал". Пример использования объектов.
Игра "Минное поле"
Большие проекты:
Электронная картотека (без исходника)


 
Пасьянс "Косынка"
Колода из 36 карт раскладывается в 8 рядов. Количество карт в каждом ряду убывает с увеличением номера ряда. Получается "косынка". Справа есть 4 места (банка), куда можно складывать карты однинаковой масти в следующей последовательности: Туз, шетерка, семерка, ..., десятка, Валет, Дама, Король. Можно перемещать карты в колонках, кладя меньшую на большую для одинаковой масти. Последовательности подряд лежащих карт (одной масти) перемещаются вместе (например, можно перенести восьмерку-семерку-шестерку на девятку). В программе использованы объекты и ссылочные переменные. Перенос из ряда в ряд осуществляется последовательным выбором двух чисел: "откуда" и "куда". "Куда" может принимать значение 0, что подразумевает "банк".

uses crt;
const
  cardVal :array[2..14] of { достоинство карты }
    string[2] =('2','3','4','5','6','7','8','9','10','J','Q','K','A');

  cardSuit :array[1..4] of char = (#6,#5,#4,#3); { масть: пики,крести,бубны,червы }
  suitColor :array[1..4] of byte = (32,32,36,36); { цвет для вывода мастей }
  topY = 2; { y-coordinate of top card in column }
  bgcolor = 2*16+14;                              { цвет экрана }
  gameTypeHidden = false; { показывать только последние в ряду карты }
  gameTypeVisible = true; { показывать все карты в ряду }

type
  pCard = ^card; { тип карты }
  card = object
    val:byte;    { достоинство }
    suit:byte;   { масть }
    x,y:byte;    { координаты на экране }
    visible:boolean;  { видимость }
    next:pCard;  { ссылка на следующуя за ней карту в ряду }
    procedure Init(_val,_suit,_x,_y:byte;_visible:boolean); { задать параметры }
    procedure Draw; { нарисовать карту согласно текущим параметрам }
  end;

  cColumn = object { колонка карт }
    n:byte;        { номер колонки }
    x:byte;        { позиция по горизонтали }
    list:pCard;    { ссылка на первую карту (самую верхнюю по вертикали) }
    procedure Draw; { нарисовать колонку карт }
    procedure Init(_n,_x:byte;_list:pCard); { задать начальные параметры }
    procedure addCard(aCard:pCard);  { добавить карту (или последовательность карт) после последней карты (вниз) }
    procedure addNewCard(val,suit:byte;vis:boolean); { Creates new card and adds it to column }
    function  getLastCard:pCard; { gets the lowest card in column }
    function  getCard(i:byte):pCard; { gets the i-st card in column }
    function  getAvailableCardNo:byte; { returns the max available card no to move }
  end;

var frm:String[12];  { рамки для рисования (псевдографика) }


procedure card.Init(_val,_suit,_x,_y:byte;_visible:boolean);
  begin
  val     := _val;
  suit    := _suit;
  x       := _x;
  y       := _y;
  visible := _visible;
  next    := nil;
  end;

procedure card.Draw;
var topL,cFace :String;
  begin
  cFace := '**'; { карта невидима (рубашкой вверх) }
  if (visible) then cFace := cardVal[val]+cardSuit[suit]; { лицо карты }
  topL := frm[1]+frm[1]+frm[5];
  if (visible and (val=10)) then
    topL := frm[1]+frm[5];
  gotoXY(x,y);
  write(frm[3]);
  if (visible) then TextAttr:=suitColor[suit]; { сменить цвет, соответствующий масти }
  write(cFace);
  TextAttr:=bgcolor; { вернуться к цвету экрана }
  write(topL);
  gotoXY(x,y+1);write(frm[2],'    ',frm[2]);
  gotoXY(x,y+2);write(frm[2],'    ',frm[2]);
  gotoXY(x,y+3);write(frm[9],frm[1],frm[1],frm[1],frm[1],frm[11]);
  end;

procedure cColumn.Init(_n,_x:byte;_list:pCard);
  begin
  n:=_n;
  x:=_x;
  list:=_list;
  end;

procedure cColumn.Draw;
var cCard:pCard;
  begin
  cCard := list;
  while cCard <> nil do
    begin
    cCard^.Draw;
    cCard := cCard^.next;
    end;
  end;

procedure cColumn.addCard(aCard:pCard); { Adds existing card to column }
var cCard:pCard;
    yK:byte;
  begin
  if (list=nil) then { no cards in column }
    begin
    list := aCard; { just add }
    yK:=topY;
    while (aCard<>nil) do
      begin
      aCard^.x:=x;
      aCard^.y:=yK;
      inc(yK);
      aCard:=aCard^.next;
      end;
    end
  else
    begin
    cCard :=list; { find last card in list }
    while cCard^.next <> nil do
      cCard := cCard^.next;
    { add to the end }
    cCard^.next := aCard;
    yK:=1+cCard^.y;
    while aCard<> nil do { добавляем все карты, следующие за aCard }
      begin
      aCard^.x:=x;
      aCard^.y:=yK;
      aCard:=aCard^.next;
      inc(yK);
      end;
    end;
  end;

procedure cColumn.addNewCard(val,suit:byte;vis:boolean); { Creates new card and adds it to column }
var pC :pCard;
  begin
  new(pC); { создать новую карту }
  pC^.Init(val,suit,1,1,vis);
  addCard(pC); { добавить в конец колонки }
  end;

function cColumn.getLastCard:pCard; { gets the lowest card in column }
var cCard:pCard;
  begin
  cCard := nil;
  if (list<>nil) then
    begin
    cCard := list;
    while cCard^.next <> nil do
      cCard := cCard^.next;
    end;
  getLastCard:=cCard;
  end;

function cColumn.getCard(i:byte):pCard; { gets the i-st card in column }
var cCard:pCard;
    k:byte;
  begin
  cCard := nil;
  if ((list<>nil) and (i>0)) then
    begin
    cCard := list;
    k:=1;
    while (cCard^.next <> nil) and (k<i) do
      begin
      cCard := cCard^.next;
      inc(k);
      end;
    end;
  getCard:=cCard;
  end;

function cColumn.getAvailableCardNo:byte; { returns the max available card no to move }
{ Получить порядковый номер (сверху) карты, ниже которой идет упорядоченный
  набор. Для закрытого типа игры это все видимые карты в колонке (они обязаны
  быть упорядочеными по убыванию). }
var cCard:pCard;
    cN,k:byte;
    vals,suits,visib:String;
    suitPatt,valPatt:char;
    lineOk:boolean;
  begin
  cN:=0;
  if (list<>nil) then
    begin
    { Если бы карты имели ссылки на предыдущую в колонке, то было бы просто.
      Но здесь карты имеют только ссылку на последующую. Нам надо проверять
      от нижней карты вверх. Поэтому записываем по отдельности масти,
      достоинства и видимость карт в строки и дальше двигаемся по полученным
      строкам от конца в начало }
    vals:='';
    suits:='';
    visib:='';
    cCard := list;
    while cCard <> nil do
      begin
      vals:=vals+chr(cCard^.val);
      suits:=suits+chr(cCard^.suit);
      if cCard^.visible
        then visib:=visib+'T'
        else visib:=visib+'F';
      cCard := cCard^.next;
      end;
    lineOk:=true;
    suitPatt := suits[length(suits)];
    valPatt := vals[length(vals)];
    k:=length(vals);
    while (lineOk and (k>0)) do
      begin
      inc(valPatt);
      dec(k);
      lineOk := (suitPatt=suits[k]) and (valPatt=vals[k]) and (visib[k]='T');
      end;
    cN := k+1;
    end;
  getAvailableCardNo := cN;
  end;

var
  columns:array[1..8] of cColumn; { массив колонок }
  i,k,n,j,kFrom,kTo,cardsLeft:shortint;
  pC :pCard;
  pack : String;
  ch:char;
  cardDone:array[1..4] of card;   { массив мест, куда складывать карты (последовательно: туз, шесть, семь,..., дама, король)  }
  gameType,moveAvailable,checkComplete:boolean;
  checkColNum,checkTo:byte;

function getNextCardFromDeck:byte;
{ взять карту с колоды (вытащить случайным образом из середины) }
var i,j:byte;
  begin
  i:=0;
  if (length(pack)>0) then
    begin
    j := 1+random(length(pack));
    i := ord(pack[j]);
    Delete(pack,j,1);
    end;
  getNextCardFromDeck := i;
  end;

function move2done(kFrom:byte;justCheck:boolean):boolean;
{ положить карту в банк, если есть такая возможность }
{ если justCheck истина, то не перемещать карту, а просто проверить
  на допустимость перемещения. (Сделано для проверки на наличие ходов) }
var pC:pCard;
    result:boolean;
  begin
  pC:=columns[kFrom].getLastCard;
  result:=false;
  if (pC^.val = cardDone[pC^.suit].val+1)
    or ((cardDone[pC^.suit].val=14) and (pC^.val=6))
  then { move allowed }
    begin
    if (not justCheck) then
      begin { перемещаем карту в банк }
      cardDone[pC^.suit].val:=pC^.val;
      cardDone[pC^.suit].visible:=true;
      { remove last card from col }
      if (pC=columns[kFrom].list) then { last card is the first one }
        begin
        Dispose(pC);
        columns[kFrom].list:=nil
        end
      else
        begin { column has more than 1 card }
        pC:=columns[kFrom].list;
        while pC^.next^.next<>nil do
          pC:=pC^.next;
        Dispose(pC^.next);
        pC^.next:=nil;
        pC^.visible:=true; { елси игра открытая, данный оператор не нужен }
        end;
      Dec(cardsLeft); { число оставшихся (не в банке) карт }
      end;
    result:=true;
    end;
  move2done := result;
  end;

function Move(kFrom,kTo:byte;justCheck:boolean):boolean;
{ Переместить карту (или последовательность карт) из одной колонки в другую }
var lCard,fCard:pCard;
    k:byte;
    result:boolean;
  procedure moveCard;
    begin
    if (not justCheck) then
      begin { перемещаем }
      columns[kTo].addCard(fCard);
      fCard:=columns[kFrom].getCard(k-1);
      if (fCard=nil)
        then columns[kFrom].list:=nil
        else
          begin
          fCard^.next:=nil;
          fCard^.visible:=true;
          end;
      end;
    result := true;
    end;
  begin { Move }
  if (kTo=0) then { запрошено перемещение в банк }
    result := (move2done(kFrom,justCheck))
  else
    begin
    lCard := columns[kTo].getLastCard; { последняя карта в колонке КУДА перемещаем }
    k := columns[kFrom].getAvailableCardNo;
    fCard:=columns[kFrom].getCard(k); { карта в колонке ОТКУДА перемещаем (верхняя карта упорядоченного ряда) }
    if (lCard=nil) then { adding to empty column }
      moveCard
    else if (fCard^.suit=lCard^.suit) then { масть совпала }
      begin
      while ((fCard<>nil) and (fCard^.val<>lCard^.val-1)) do
      { здесь достаточно простого сравнения без while. Но сделан задел в
        расчете на то, что возможно будет раскладываться не одна колода }
        begin
        fCard:=fCard^.next;
        Inc(k);
        end;
      if (fCard<>nil) then { ok to move }
        moveCard
      else { перемещение невозможно }
        result := false;
      end
    else { масть не совпала }
      result := false;
    end;
  Move:=result;
  end;


procedure displayAll; { Отрисовать все }
  begin
  clrscr;
  for i:=1 to 8 do
    begin
    gotoXY(i*6-2,1);write(i);
    columns[i].Draw;
    end;
  for i:=1 to 4 do
    begin
    gotoXY(51+i*6,1);write('0');
    {dp.init(0,0,48+6*i,topY,false);}
    cardDone[i].Draw;
    end;
  GotoXY(55,8);write('Cards Left: ',cardsLeft);
  GotoXY(55,10);write('Chose two column numbers:');
  GotoXY(57,11);write('From and To');
  end;


procedure restartCheck; { инициализировать проверку на допустимость перемещений }
  begin
  moveAvailable:=false;
  checkComplete:=false;
  checkColNum:=1; checkTo:=0;
  end;

procedure chekMoveAvailable;
{ Проверка на допустимость перемещений. Осуществляется в фоновом режиме, пока
  игрок думает. }
  begin
  if (not checkComplete) then
    if (move(checkColNum,checkTo,true)) then
      begin { хотя бы один ход возможен, прекращаем дальнейшую проверку }
      moveAvailable:=true;
      checkComplete:=true;
      gotoXY(50,16);write('T');
      end
    else
      begin { данный ход недопустим. подготовим параметры для проверки следующего хода }
      inc(checkTo);
      if (checkTo>8) then
        begin
        checkTo:=0;
        inc(checkColNum);
        if (checkColNum>8) then
          checkComplete:=true; { все допустимые ходы перебраны, никакие перемещения невозможны, прекращаем проверку. }
        end
      end
  end;

begin { основная программа }
gameType := gameTypeHidden; { закрытый тип игры }
gameType := gameTypeVisible; { открытый тип игры }
       {12345678901}
frm := '-¦-T¬+++L+-'; {'¦+¦¦¬¬¦¦¬---¬L+T+-+¦¦Lг¦T¦=+¦¦TTLL-г++--';}
frm := '-!+++++++++'; { обычные символы, елси вдруг не работает псевдографика }
frm := #196#179#218#194#191#195#197#180#192#193#217; { псевдографика }
TextAttr:=bgcolor;
clrscr;
{ Инициализация колонок и банков }
for i:=1 to 8 do columns[i].Init(i,1+(i-1)*6,nil);
for i:=1 to 4 do
  cardDone[i].init(13,i,48+6*i,topY,false);


{ Разложить карты }
randomize;
pack := ''; { колода }
for i:=1 to 36 do pack := pack + chr(i);
for k:=1 to 8 do
  begin
  for j:=1 to 8-k do
    begin
    i:=getNextCardFromDeck;
    columns[k].addNewCard(6+(i mod 9),1+((i-1) div 9),gameType);
    end;
  { последняя карта в колонке открыта всегда }
  i:=getNextCardFromDeck;
  columns[k].addNewCard(6+(i mod 9),1+((i-1) div 9),true);
  end;

cardsLeft:=36;
displayAll;

kFrom:=-1;kTo:=-1;ch:=' ';
restartCheck;
repeat
  if keyPressed then
    begin
    ch:=readkey;
    if (ch in ['0'..'8']) then
      begin
      if (kFrom<0)
        then
          begin
          kFrom:=ord(ch)-ord('0');
          gotoXY(19,23);write(ch,'->         ');gotoXY(1,1);
          end
        else
          begin
          kTo:=ord(ch)-ord('0');
          if (move(kFrom,kTo,false)) then
            begin
            displayAll;
            gotoXY(19,23);
            writeln('move done');
            restartCheck;
            end
          else
            begin
            gotoXY(19,23);
            writeln('not possible to move');
            end;
          kFrom:=-1;kTo:=-1;
          end;
      end;
    end
  else chekMoveAvailable;
until (ch=#27) or (cardsLeft<1) or (checkComplete and (not moveAvailable));
if (cardsLeft<1) then { сошлось! }
  begin
  gotoXY(19,23);
  write('Well done!            ');
  end else
if (not moveAvailable) then { не сошлось  }
  begin
  gotoXY(19,23);
  write('No more moves available.');
  end;
end.