(DEFUN COD (LAMBDA (X LST)
   ; ------------------------------------------------- ;
   ;  Кодиpование Фано: X - кодиpуемый "лист" деpева,  ;
   ;  LST - бинаpное деpево с pазмеченными листьями    ;
   ; ------------------------------------------------- ;
       (COND ( (ATOM LST) NIL )
             ( (CONTAINS X (CAR LST))
                       (CONS O (COD X (CAR LST))) )
             ( (CONTAINS X (CDR LST))
                       (CONS L (COD X (CDR LST))) )
       )
   ))
   ; --------------------------- ;
   (DEFUN CONTAINS (LAMBDA (X LST)
   ; Пpедикат для пpовеpки пpинадлежности X списку LST ;
       (COND ( (ATOM LST) (EQ X LST) )
             (  T  (OR (CONTAINS X (CAR LST))
                       (CONTAINS X (CDR LST))) )
       )
   ))

   FUNCTION  C_o_d (S: Lisp; X: TipElement): BitString;
   { --------------------------------------------- }
   {  Кодиpование Фано                             }
   {  S - бинаpное деpево с pазмеченными листьями, }
   {  X - "содеpжимое" листа деpева S              }
   { --------------------------------------------- }
   BEGIN
      If  ATOM (S)
         then  C_o_d := ''
         else  If  C_o_n_t_a_i_n_s (CAR(S),X)
                  then  C_o_d := Concat ('O',C_o_d (CAR(S),X))
                  else  If  C_o_n_t_a_i_n_s (CDR(S),X)
                           then  C_o_d := Concat ('L',C_o_d (CDR(S),X))
   END;
  { ---------------------------------------------------- }
   FUNCTION  C_o_n_t_a_i_n_s (S: Lisp; X: Char): Boolean;
   BEGIN
      If  ATOM (S)
         then  C_o_n_t_a_i_n_s := X=VAL(S)
         else  C_o_n_t_a_i_n_s := C_o_n_t_a_i_n_s (CAR(S),X) OR
                                  C_o_n_t_a_i_n_s (CDR(S),X)
   END;

   (DEFUN DECOD (LAMBDA (CODE LST)
   ;  Декодиpование Ф а н о: CODE - код Фано,        ;
   ;  LST - бинаpное деpево с pазмеченными листьями  ;
       (COND ( (OR (ATOM LST) (NULL CODE)) LST )
             ( (EQ (CAR CODE) O)
                         (DECOD (CDR CODE) (CAR LST)) )
             ( (EQ (CAR CODE) L)
                         (DECOD (CDR CODE) (CDR LST)) )
       )
   ))

   FUNCTION  D_e_c_o_d  (S: Lisp; A: BitString): TipElement;
   {  Декодиpование Фано                          }
   {  A - код Фано,                               }
   {  S - бинаpное деpево с pазмеченными листьями }
   BEGIN
      If  (ATOM (S)) OR (A='')
         then  D_e_c_o_d := VAL(S)
         else  If  Copy (A,1,1) = 'O'
                  then  D_e_c_o_d  :=
                            D_e_c_o_d (CAR(S),Copy (A,2,Length(A)-1))
                  else  If  Copy (A,1,1) = 'L'
                           then   D_e_c_o_d  :=
                                     D_e_c_o_d (CDR(S),
                                                Copy (A,2,Length(A)-1))
   END;

   PROGRAM  C_o_d_F_a_n_o;    {$A-}
   { Кодирование и декодирование Фано }
   {     "листьев" точечных пар       }
      type  TipElement = Char;
            Lisp       = ^LispEl;
            LispEl     = Record
                           Case Tag: (Single,Pair) of
                                      { А т о м  }
                              Single: (Leaf : TipElement);
                                      { Точечная пара }
                              Pair  : (Left : Lisp;
                                       Right: Lisp)
                           End;
            Stroka     = String [23];
            BitString  = String [50];
     { -------------------------------------------------- }
      var  Root  : Lisp;     { Указатель на точечную пару }
           Strk  : Stroka;   { Строка - точечная пара     }
           Result: Stroka;
           i     : Integer;  { Вспомогательная переменная }
           Code  : BitString;
           Symbol: TipElement;
  { --------------------------------- }
   PROCEDURE  E_n_t_e_r (var T: Lisp);
   { Построение бинарного дерева,            }
   { соответствующего S-выражению языка LISP }
      var  X: TipElement;
   BEGIN
      Write (' '); X := Strk[i]; i := i + 1;
     { Помещаем элемент точечной пары X в бинарное дерево }
      If  X='#'
         then  begin
                  New (T); T^.Tag := Pair;
                  E_n_t_e_r (T^.Left); E_n_t_e_r (T^.Right)
               end
         else  begin
                  New (T); T^.Tag := Single;
                  T^.Leaf := X
               end
   END;
  { ------------------------------------------------- }
   PROCEDURE  P_r_i_n_t_T_r_e_e (W: Lisp; l: Integer);
   { Вывод бинарного дерева, соответствующего }
   {             точечной паре W              }
      var  i: Integer;
   BEGIN
      If  W^.Tag <> Single
         then  begin
                  P_r_i_n_t_T_r_e_e (W^.Right,l+1);
                  For i:=1 to l do  Write ('   ');
                  Writeln ('#');
                  P_r_i_n_t_T_r_e_e (W^.Left,l+1)
               end
         else  begin
                  For i:=1 to l do  Write ('   ');
                  Writeln (W^.Leaf)
               end
   END;
  { ------------------------------------ }
   PROCEDURE  C_o_n_v_e_r_t (Strk: Stroka;
                             var Result: Stroka);
      var  k : Integer;  { Параметр цикла         }
           Ch: Char;     { Вспомогательный символ }
   BEGIN
      Result := '';
      For k:=1 to Length (Strk)  do
         begin
            Ch := Strk[k];
            If  Ch='('
               then  Result := Result + '#'
               else  If  (Ch<>')') AND (Ch<>'.')
                                   AND (Ch<>' ')
                        then  Result := Result + Ch
         end
   END;
  { -------------------------------- }
   FUNCTION  ATOM (X: Lisp): Boolean;
   { Проверка типа аргумента }
   BEGIN
      ATOM := (X^.Tag = Single)
   END;
  { ---------------------------- }
   FUNCTION  CAR (X: Lisp): Lisp;
   { Выделение первой компоненты S-выражения }
   BEGIN
      CAR := X^.Left
   END;
  { ---------------------------- }
   FUNCTION  CDR (X: Lisp): Lisp;
   { Выделение второй компоненты S-выражения }
   BEGIN
      CDR := X^.Right
   END;
  { ---------------------------------- }
   FUNCTION  VAL (A: Lisp): TipElement;
   BEGIN
      VAL := A^.Leaf
   END;
  { ---------------------------------------------------- }
   FUNCTION  C_o_n_t_a_i_n_s (S: Lisp; X: Char): Boolean;
   BEGIN
      If  ATOM (S)
         then  C_o_n_t_a_i_n_s := X=VAL(S)
         else  C_o_n_t_a_i_n_s :=
                          C_o_n_t_a_i_n_s (CAR(S),X) OR
                          C_o_n_t_a_i_n_s (CDR(S),X)
   END;
  { -------------------------------------------------- }
   FUNCTION  C_o_d (S: Lisp; X: TipElement): BitString;
   { Кодирование Фано:                            }
   { S - бинарное дерево с размеченными листьями, }
   { X - "содержимое" листа дерева S              }
   BEGIN
      If  ATOM (S)
         then  C_o_d := ''
         else  If  C_o_n_t_a_i_n_s (CAR(S),X)
                  then  C_o_d := Concat ('O',C_o_d (CAR(S),X))
                  else  If  C_o_n_t_a_i_n_s (CDR(S),X)
                           then  C_o_d :=
                                  Concat('L',C_o_d (CDR(S),X))
   END;
  { ------------------------------------------------------- }
   FUNCTION  D_e_c_o_d  (S: Lisp; A: BitString): TipElement;
   { Декодирование Фано:                         }
   { A - код Фано,                               }
   { S - бинарное дерево с размеченными листьями }
   BEGIN
      If  (ATOM (S)) OR (A='')
         then  D_e_c_o_d := VAL(S)
         else  If  Copy (A,1,1) = 'O'
                  then  D_e_c_o_d  :=
                            D_e_c_o_d (CAR(S),
                                    Copy (A,2,Length(A)-1))
                  else  If  Copy (A,1,1) = 'L'
                           then   D_e_c_o_d  :=
                                    D_e_c_o_d (CDR(S),
                                    Copy (A,2,Length(A)-1))
   END;
  { ---- }
   BEGIN
      Writeln
     ('Построим бинарное дерево с размеченными листьями ');
      Writeln ('по заданной лисповской точечной паре... ');
      Writeln ('Вводите точечную пару... ');
      i := 1; ReadLn (Strk); C_o_n_v_e_r_t (Strk,Result);
      Strk := Result; Root := Nil; E_n_t_e_r (Root);
      Writeln; P_r_i_n_t_T_r_e_e (Root,0); Writeln;
      Writeln (' -------------------------------------- ');
      For i:=1 to 4  do
         begin
            Write ('Кодирование Фано символа ');
            ReadLn (Symbol);
            If  C_o_n_t_a_i_n_s (Root,Symbol)
               then  Writeln (' ... ',C_o_d (Root,Symbol))
               else  Writeln (' - Символа в дереве нет!')
         end;
      Writeln (' -------------------------------------- ');
      Writeln ('Приступим к декодированию...');
      For i:=1 to 4  do
         begin
            Write ('Введите код... '); ReadLn (Code);
            Write (' - ');
            If  C_o_d (Root,D_e_c_o_d (Root,Code)) = Code
               then  Writeln (D_e_c_o_d (Root,Code))
               else  Writeln ('Код неверен!')
         end
   END.